[25] | 1 | /* |
---|
| 2 | * tclCmdMZ.c -- |
---|
| 3 | * |
---|
| 4 | * This file contains the top-level command routines for most of the Tcl |
---|
| 5 | * built-in commands whose names begin with the letters M to Z. It |
---|
| 6 | * contains only commands in the generic core (i.e. those that don't |
---|
| 7 | * depend much upon UNIX facilities). |
---|
| 8 | * |
---|
| 9 | * Copyright (c) 1987-1993 The Regents of the University of California. |
---|
| 10 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. |
---|
| 11 | * Copyright (c) 1998-2000 Scriptics Corporation. |
---|
| 12 | * Copyright (c) 2002 ActiveState Corporation. |
---|
| 13 | * Copyright (c) 2003 Donal K. Fellows. |
---|
| 14 | * |
---|
| 15 | * See the file "license.terms" for information on usage and redistribution of |
---|
| 16 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 17 | * |
---|
| 18 | * RCS: @(#) $Id: tclCmdMZ.c,v 1.163 2007/12/13 15:23:15 dgp Exp $ |
---|
| 19 | */ |
---|
| 20 | |
---|
| 21 | #include "tclInt.h" |
---|
| 22 | #include "tclRegexp.h" |
---|
| 23 | |
---|
| 24 | static int UniCharIsAscii(int character); |
---|
| 25 | |
---|
| 26 | /* |
---|
| 27 | *---------------------------------------------------------------------- |
---|
| 28 | * |
---|
| 29 | * Tcl_PwdObjCmd -- |
---|
| 30 | * |
---|
| 31 | * This procedure is invoked to process the "pwd" Tcl command. See the |
---|
| 32 | * user documentation for details on what it does. |
---|
| 33 | * |
---|
| 34 | * Results: |
---|
| 35 | * A standard Tcl result. |
---|
| 36 | * |
---|
| 37 | * Side effects: |
---|
| 38 | * See the user documentation. |
---|
| 39 | * |
---|
| 40 | *---------------------------------------------------------------------- |
---|
| 41 | */ |
---|
| 42 | |
---|
| 43 | int |
---|
| 44 | Tcl_PwdObjCmd( |
---|
| 45 | ClientData dummy, /* Not used. */ |
---|
| 46 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 47 | int objc, /* Number of arguments. */ |
---|
| 48 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 49 | { |
---|
| 50 | Tcl_Obj *retVal; |
---|
| 51 | |
---|
| 52 | if (objc != 1) { |
---|
| 53 | Tcl_WrongNumArgs(interp, 1, objv, NULL); |
---|
| 54 | return TCL_ERROR; |
---|
| 55 | } |
---|
| 56 | |
---|
| 57 | retVal = Tcl_FSGetCwd(interp); |
---|
| 58 | if (retVal == NULL) { |
---|
| 59 | return TCL_ERROR; |
---|
| 60 | } |
---|
| 61 | Tcl_SetObjResult(interp, retVal); |
---|
| 62 | Tcl_DecrRefCount(retVal); |
---|
| 63 | return TCL_OK; |
---|
| 64 | } |
---|
| 65 | |
---|
| 66 | /* |
---|
| 67 | *---------------------------------------------------------------------- |
---|
| 68 | * |
---|
| 69 | * Tcl_RegexpObjCmd -- |
---|
| 70 | * |
---|
| 71 | * This procedure is invoked to process the "regexp" Tcl command. See |
---|
| 72 | * the user documentation for details on what it does. |
---|
| 73 | * |
---|
| 74 | * Results: |
---|
| 75 | * A standard Tcl result. |
---|
| 76 | * |
---|
| 77 | * Side effects: |
---|
| 78 | * See the user documentation. |
---|
| 79 | * |
---|
| 80 | *---------------------------------------------------------------------- |
---|
| 81 | */ |
---|
| 82 | |
---|
| 83 | int |
---|
| 84 | Tcl_RegexpObjCmd( |
---|
| 85 | ClientData dummy, /* Not used. */ |
---|
| 86 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 87 | int objc, /* Number of arguments. */ |
---|
| 88 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 89 | { |
---|
| 90 | int i, indices, match, about, offset, all, doinline, numMatchesSaved; |
---|
| 91 | int cflags, eflags, stringLength; |
---|
| 92 | Tcl_RegExp regExpr; |
---|
| 93 | Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL; |
---|
| 94 | Tcl_RegExpInfo info; |
---|
| 95 | static CONST char *options[] = { |
---|
| 96 | "-all", "-about", "-indices", "-inline", |
---|
| 97 | "-expanded", "-line", "-linestop", "-lineanchor", |
---|
| 98 | "-nocase", "-start", "--", NULL |
---|
| 99 | }; |
---|
| 100 | enum options { |
---|
| 101 | REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, |
---|
| 102 | REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, |
---|
| 103 | REGEXP_NOCASE, REGEXP_START, REGEXP_LAST |
---|
| 104 | }; |
---|
| 105 | |
---|
| 106 | indices = 0; |
---|
| 107 | about = 0; |
---|
| 108 | cflags = TCL_REG_ADVANCED; |
---|
| 109 | eflags = 0; |
---|
| 110 | offset = 0; |
---|
| 111 | all = 0; |
---|
| 112 | doinline = 0; |
---|
| 113 | |
---|
| 114 | for (i = 1; i < objc; i++) { |
---|
| 115 | char *name; |
---|
| 116 | int index; |
---|
| 117 | |
---|
| 118 | name = TclGetString(objv[i]); |
---|
| 119 | if (name[0] != '-') { |
---|
| 120 | break; |
---|
| 121 | } |
---|
| 122 | if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, |
---|
| 123 | &index) != TCL_OK) { |
---|
| 124 | goto optionError; |
---|
| 125 | } |
---|
| 126 | switch ((enum options) index) { |
---|
| 127 | case REGEXP_ALL: |
---|
| 128 | all = 1; |
---|
| 129 | break; |
---|
| 130 | case REGEXP_INDICES: |
---|
| 131 | indices = 1; |
---|
| 132 | break; |
---|
| 133 | case REGEXP_INLINE: |
---|
| 134 | doinline = 1; |
---|
| 135 | break; |
---|
| 136 | case REGEXP_NOCASE: |
---|
| 137 | cflags |= TCL_REG_NOCASE; |
---|
| 138 | break; |
---|
| 139 | case REGEXP_ABOUT: |
---|
| 140 | about = 1; |
---|
| 141 | break; |
---|
| 142 | case REGEXP_EXPANDED: |
---|
| 143 | cflags |= TCL_REG_EXPANDED; |
---|
| 144 | break; |
---|
| 145 | case REGEXP_LINE: |
---|
| 146 | cflags |= TCL_REG_NEWLINE; |
---|
| 147 | break; |
---|
| 148 | case REGEXP_LINESTOP: |
---|
| 149 | cflags |= TCL_REG_NLSTOP; |
---|
| 150 | break; |
---|
| 151 | case REGEXP_LINEANCHOR: |
---|
| 152 | cflags |= TCL_REG_NLANCH; |
---|
| 153 | break; |
---|
| 154 | case REGEXP_START: { |
---|
| 155 | int temp; |
---|
| 156 | if (++i >= objc) { |
---|
| 157 | goto endOfForLoop; |
---|
| 158 | } |
---|
| 159 | if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) { |
---|
| 160 | goto optionError; |
---|
| 161 | } |
---|
| 162 | if (startIndex) { |
---|
| 163 | Tcl_DecrRefCount(startIndex); |
---|
| 164 | } |
---|
| 165 | startIndex = objv[i]; |
---|
| 166 | Tcl_IncrRefCount(startIndex); |
---|
| 167 | break; |
---|
| 168 | } |
---|
| 169 | case REGEXP_LAST: |
---|
| 170 | i++; |
---|
| 171 | goto endOfForLoop; |
---|
| 172 | } |
---|
| 173 | } |
---|
| 174 | |
---|
| 175 | endOfForLoop: |
---|
| 176 | if ((objc - i) < (2 - about)) { |
---|
| 177 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 178 | "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); |
---|
| 179 | goto optionError; |
---|
| 180 | } |
---|
| 181 | objc -= i; |
---|
| 182 | objv += i; |
---|
| 183 | |
---|
| 184 | /* |
---|
| 185 | * Check if the user requested -inline, but specified match variables; a |
---|
| 186 | * no-no. |
---|
| 187 | */ |
---|
| 188 | |
---|
| 189 | if (doinline && ((objc - 2) != 0)) { |
---|
| 190 | Tcl_AppendResult(interp, "regexp match variables not allowed" |
---|
| 191 | " when using -inline", NULL); |
---|
| 192 | goto optionError; |
---|
| 193 | } |
---|
| 194 | |
---|
| 195 | /* |
---|
| 196 | * Handle the odd about case separately. |
---|
| 197 | */ |
---|
| 198 | |
---|
| 199 | if (about) { |
---|
| 200 | regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); |
---|
| 201 | if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { |
---|
| 202 | optionError: |
---|
| 203 | if (startIndex) { |
---|
| 204 | Tcl_DecrRefCount(startIndex); |
---|
| 205 | } |
---|
| 206 | return TCL_ERROR; |
---|
| 207 | } |
---|
| 208 | return TCL_OK; |
---|
| 209 | } |
---|
| 210 | |
---|
| 211 | /* |
---|
| 212 | * Get the length of the string that we are matching against so we can do |
---|
| 213 | * the termination test for -all matches. Do this before getting the |
---|
| 214 | * regexp to avoid shimmering problems. |
---|
| 215 | */ |
---|
| 216 | |
---|
| 217 | objPtr = objv[1]; |
---|
| 218 | stringLength = Tcl_GetCharLength(objPtr); |
---|
| 219 | |
---|
| 220 | if (startIndex) { |
---|
| 221 | TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); |
---|
| 222 | Tcl_DecrRefCount(startIndex); |
---|
| 223 | if (offset < 0) { |
---|
| 224 | offset = 0; |
---|
| 225 | } |
---|
| 226 | } |
---|
| 227 | |
---|
| 228 | regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); |
---|
| 229 | if (regExpr == NULL) { |
---|
| 230 | return TCL_ERROR; |
---|
| 231 | } |
---|
| 232 | |
---|
| 233 | if (offset > 0) { |
---|
| 234 | /* |
---|
| 235 | * Add flag if using offset (string is part of a larger string), so |
---|
| 236 | * that "^" won't match. |
---|
| 237 | */ |
---|
| 238 | |
---|
| 239 | eflags |= TCL_REG_NOTBOL; |
---|
| 240 | } |
---|
| 241 | |
---|
| 242 | objc -= 2; |
---|
| 243 | objv += 2; |
---|
| 244 | |
---|
| 245 | if (doinline) { |
---|
| 246 | /* |
---|
| 247 | * Save all the subexpressions, as we will return them as a list |
---|
| 248 | */ |
---|
| 249 | |
---|
| 250 | numMatchesSaved = -1; |
---|
| 251 | } else { |
---|
| 252 | /* |
---|
| 253 | * Save only enough subexpressions for matches we want to keep, expect |
---|
| 254 | * in the case of -all, where we need to keep at least one to know |
---|
| 255 | * where to move the offset. |
---|
| 256 | */ |
---|
| 257 | |
---|
| 258 | numMatchesSaved = (objc == 0) ? all : objc; |
---|
| 259 | } |
---|
| 260 | |
---|
| 261 | /* |
---|
| 262 | * The following loop is to handle multiple matches within the same source |
---|
| 263 | * string; each iteration handles one match. If "-all" hasn't been |
---|
| 264 | * specified then the loop body only gets executed once. We terminate the |
---|
| 265 | * loop when the starting offset is past the end of the string. |
---|
| 266 | */ |
---|
| 267 | |
---|
| 268 | while (1) { |
---|
| 269 | match = Tcl_RegExpExecObj(interp, regExpr, objPtr, |
---|
| 270 | offset /* offset */, numMatchesSaved, eflags |
---|
| 271 | | ((offset > 0 && |
---|
| 272 | (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n')) |
---|
| 273 | ? TCL_REG_NOTBOL : 0)); |
---|
| 274 | |
---|
| 275 | if (match < 0) { |
---|
| 276 | return TCL_ERROR; |
---|
| 277 | } |
---|
| 278 | |
---|
| 279 | if (match == 0) { |
---|
| 280 | /* |
---|
| 281 | * We want to set the value of the intepreter result only when |
---|
| 282 | * this is the first time through the loop. |
---|
| 283 | */ |
---|
| 284 | |
---|
| 285 | if (all <= 1) { |
---|
| 286 | /* |
---|
| 287 | * If inlining, the interpreter's object result remains an |
---|
| 288 | * empty list, otherwise set it to an integer object w/ value |
---|
| 289 | * 0. |
---|
| 290 | */ |
---|
| 291 | |
---|
| 292 | if (!doinline) { |
---|
| 293 | Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); |
---|
| 294 | } |
---|
| 295 | return TCL_OK; |
---|
| 296 | } |
---|
| 297 | break; |
---|
| 298 | } |
---|
| 299 | |
---|
| 300 | /* |
---|
| 301 | * If additional variable names have been specified, return index |
---|
| 302 | * information in those variables. |
---|
| 303 | */ |
---|
| 304 | |
---|
| 305 | Tcl_RegExpGetInfo(regExpr, &info); |
---|
| 306 | if (doinline) { |
---|
| 307 | /* |
---|
| 308 | * It's the number of substitutions, plus one for the matchVar at |
---|
| 309 | * index 0 |
---|
| 310 | */ |
---|
| 311 | |
---|
| 312 | objc = info.nsubs + 1; |
---|
| 313 | if (all <= 1) { |
---|
| 314 | resultPtr = Tcl_NewObj(); |
---|
| 315 | } |
---|
| 316 | } |
---|
| 317 | for (i = 0; i < objc; i++) { |
---|
| 318 | Tcl_Obj *newPtr; |
---|
| 319 | |
---|
| 320 | if (indices) { |
---|
| 321 | int start, end; |
---|
| 322 | Tcl_Obj *objs[2]; |
---|
| 323 | |
---|
| 324 | /* |
---|
| 325 | * Only adjust the match area if there was a match for that |
---|
| 326 | * area. (Scriptics Bug 4391/SF Bug #219232) |
---|
| 327 | */ |
---|
| 328 | |
---|
| 329 | if (i <= info.nsubs && info.matches[i].start >= 0) { |
---|
| 330 | start = offset + info.matches[i].start; |
---|
| 331 | end = offset + info.matches[i].end; |
---|
| 332 | |
---|
| 333 | /* |
---|
| 334 | * Adjust index so it refers to the last character in the |
---|
| 335 | * match instead of the first character after the match. |
---|
| 336 | */ |
---|
| 337 | |
---|
| 338 | if (end >= offset) { |
---|
| 339 | end--; |
---|
| 340 | } |
---|
| 341 | } else { |
---|
| 342 | start = -1; |
---|
| 343 | end = -1; |
---|
| 344 | } |
---|
| 345 | |
---|
| 346 | objs[0] = Tcl_NewLongObj(start); |
---|
| 347 | objs[1] = Tcl_NewLongObj(end); |
---|
| 348 | |
---|
| 349 | newPtr = Tcl_NewListObj(2, objs); |
---|
| 350 | } else { |
---|
| 351 | if (i <= info.nsubs) { |
---|
| 352 | newPtr = Tcl_GetRange(objPtr, |
---|
| 353 | offset + info.matches[i].start, |
---|
| 354 | offset + info.matches[i].end - 1); |
---|
| 355 | } else { |
---|
| 356 | newPtr = Tcl_NewObj(); |
---|
| 357 | } |
---|
| 358 | } |
---|
| 359 | if (doinline) { |
---|
| 360 | if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr) |
---|
| 361 | != TCL_OK) { |
---|
| 362 | Tcl_DecrRefCount(newPtr); |
---|
| 363 | Tcl_DecrRefCount(resultPtr); |
---|
| 364 | return TCL_ERROR; |
---|
| 365 | } |
---|
| 366 | } else { |
---|
| 367 | Tcl_Obj *valuePtr; |
---|
| 368 | valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); |
---|
| 369 | if (valuePtr == NULL) { |
---|
| 370 | Tcl_AppendResult(interp, "couldn't set variable \"", |
---|
| 371 | TclGetString(objv[i]), "\"", NULL); |
---|
| 372 | return TCL_ERROR; |
---|
| 373 | } |
---|
| 374 | } |
---|
| 375 | } |
---|
| 376 | |
---|
| 377 | if (all == 0) { |
---|
| 378 | break; |
---|
| 379 | } |
---|
| 380 | |
---|
| 381 | /* |
---|
| 382 | * Adjust the offset to the character just after the last one in the |
---|
| 383 | * matchVar and increment all to count how many times we are making a |
---|
| 384 | * match. We always increment the offset by at least one to prevent |
---|
| 385 | * endless looping (as in the case: regexp -all {a*} a). Otherwise, |
---|
| 386 | * when we match the NULL string at the end of the input string, we |
---|
| 387 | * will loop indefinately (because the length of the match is 0, so |
---|
| 388 | * offset never changes). |
---|
| 389 | */ |
---|
| 390 | |
---|
| 391 | if (info.matches[0].end == 0) { |
---|
| 392 | offset++; |
---|
| 393 | } |
---|
| 394 | offset += info.matches[0].end; |
---|
| 395 | all++; |
---|
| 396 | eflags |= TCL_REG_NOTBOL; |
---|
| 397 | if (offset >= stringLength) { |
---|
| 398 | break; |
---|
| 399 | } |
---|
| 400 | } |
---|
| 401 | |
---|
| 402 | /* |
---|
| 403 | * Set the interpreter's object result to an integer object with value 1 |
---|
| 404 | * if -all wasn't specified, otherwise it's all-1 (the number of times |
---|
| 405 | * through the while - 1). |
---|
| 406 | */ |
---|
| 407 | |
---|
| 408 | if (doinline) { |
---|
| 409 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 410 | } else { |
---|
| 411 | Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1)); |
---|
| 412 | } |
---|
| 413 | return TCL_OK; |
---|
| 414 | } |
---|
| 415 | |
---|
| 416 | /* |
---|
| 417 | *---------------------------------------------------------------------- |
---|
| 418 | * |
---|
| 419 | * Tcl_RegsubObjCmd -- |
---|
| 420 | * |
---|
| 421 | * This procedure is invoked to process the "regsub" Tcl command. See the |
---|
| 422 | * user documentation for details on what it does. |
---|
| 423 | * |
---|
| 424 | * Results: |
---|
| 425 | * A standard Tcl result. |
---|
| 426 | * |
---|
| 427 | * Side effects: |
---|
| 428 | * See the user documentation. |
---|
| 429 | * |
---|
| 430 | *---------------------------------------------------------------------- |
---|
| 431 | */ |
---|
| 432 | |
---|
| 433 | int |
---|
| 434 | Tcl_RegsubObjCmd( |
---|
| 435 | ClientData dummy, /* Not used. */ |
---|
| 436 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 437 | int objc, /* Number of arguments. */ |
---|
| 438 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 439 | { |
---|
| 440 | int idx, result, cflags, all, wlen, wsublen, numMatches, offset; |
---|
| 441 | int start, end, subStart, subEnd, match; |
---|
| 442 | Tcl_RegExp regExpr; |
---|
| 443 | Tcl_RegExpInfo info; |
---|
| 444 | Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; |
---|
| 445 | Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; |
---|
| 446 | |
---|
| 447 | static CONST char *options[] = { |
---|
| 448 | "-all", "-nocase", "-expanded", |
---|
| 449 | "-line", "-linestop", "-lineanchor", "-start", |
---|
| 450 | "--", NULL |
---|
| 451 | }; |
---|
| 452 | enum options { |
---|
| 453 | REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, |
---|
| 454 | REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, |
---|
| 455 | REGSUB_LAST |
---|
| 456 | }; |
---|
| 457 | |
---|
| 458 | cflags = TCL_REG_ADVANCED; |
---|
| 459 | all = 0; |
---|
| 460 | offset = 0; |
---|
| 461 | resultPtr = NULL; |
---|
| 462 | |
---|
| 463 | for (idx = 1; idx < objc; idx++) { |
---|
| 464 | char *name; |
---|
| 465 | int index; |
---|
| 466 | |
---|
| 467 | name = TclGetString(objv[idx]); |
---|
| 468 | if (name[0] != '-') { |
---|
| 469 | break; |
---|
| 470 | } |
---|
| 471 | if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", |
---|
| 472 | TCL_EXACT, &index) != TCL_OK) { |
---|
| 473 | goto optionError; |
---|
| 474 | } |
---|
| 475 | switch ((enum options) index) { |
---|
| 476 | case REGSUB_ALL: |
---|
| 477 | all = 1; |
---|
| 478 | break; |
---|
| 479 | case REGSUB_NOCASE: |
---|
| 480 | cflags |= TCL_REG_NOCASE; |
---|
| 481 | break; |
---|
| 482 | case REGSUB_EXPANDED: |
---|
| 483 | cflags |= TCL_REG_EXPANDED; |
---|
| 484 | break; |
---|
| 485 | case REGSUB_LINE: |
---|
| 486 | cflags |= TCL_REG_NEWLINE; |
---|
| 487 | break; |
---|
| 488 | case REGSUB_LINESTOP: |
---|
| 489 | cflags |= TCL_REG_NLSTOP; |
---|
| 490 | break; |
---|
| 491 | case REGSUB_LINEANCHOR: |
---|
| 492 | cflags |= TCL_REG_NLANCH; |
---|
| 493 | break; |
---|
| 494 | case REGSUB_START: { |
---|
| 495 | int temp; |
---|
| 496 | if (++idx >= objc) { |
---|
| 497 | goto endOfForLoop; |
---|
| 498 | } |
---|
| 499 | if (TclGetIntForIndexM(interp, objv[idx], 0, &temp) != TCL_OK) { |
---|
| 500 | goto optionError; |
---|
| 501 | } |
---|
| 502 | if (startIndex) { |
---|
| 503 | Tcl_DecrRefCount(startIndex); |
---|
| 504 | } |
---|
| 505 | startIndex = objv[idx]; |
---|
| 506 | Tcl_IncrRefCount(startIndex); |
---|
| 507 | break; |
---|
| 508 | } |
---|
| 509 | case REGSUB_LAST: |
---|
| 510 | idx++; |
---|
| 511 | goto endOfForLoop; |
---|
| 512 | } |
---|
| 513 | } |
---|
| 514 | |
---|
| 515 | endOfForLoop: |
---|
| 516 | if (objc-idx < 3 || objc-idx > 4) { |
---|
| 517 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 518 | "?switches? exp string subSpec ?varName?"); |
---|
| 519 | optionError: |
---|
| 520 | if (startIndex) { |
---|
| 521 | Tcl_DecrRefCount(startIndex); |
---|
| 522 | } |
---|
| 523 | return TCL_ERROR; |
---|
| 524 | } |
---|
| 525 | |
---|
| 526 | objc -= idx; |
---|
| 527 | objv += idx; |
---|
| 528 | |
---|
| 529 | if (startIndex) { |
---|
| 530 | int stringLength = Tcl_GetCharLength(objv[1]); |
---|
| 531 | |
---|
| 532 | TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); |
---|
| 533 | Tcl_DecrRefCount(startIndex); |
---|
| 534 | if (offset < 0) { |
---|
| 535 | offset = 0; |
---|
| 536 | } |
---|
| 537 | } |
---|
| 538 | |
---|
| 539 | if (all && (offset == 0) |
---|
| 540 | && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) |
---|
| 541 | && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { |
---|
| 542 | /* |
---|
| 543 | * This is a simple one pair string map situation. We make use of a |
---|
| 544 | * slightly modified version of the one pair STR_MAP code. |
---|
| 545 | */ |
---|
| 546 | |
---|
| 547 | int slen, nocase; |
---|
| 548 | int (*strCmpFn)(CONST Tcl_UniChar*,CONST Tcl_UniChar*,unsigned long); |
---|
| 549 | Tcl_UniChar *p, wsrclc; |
---|
| 550 | |
---|
| 551 | numMatches = 0; |
---|
| 552 | nocase = (cflags & TCL_REG_NOCASE); |
---|
| 553 | strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; |
---|
| 554 | |
---|
| 555 | wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); |
---|
| 556 | wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); |
---|
| 557 | wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); |
---|
| 558 | wend = wstring + wlen - (slen ? slen - 1 : 0); |
---|
| 559 | result = TCL_OK; |
---|
| 560 | |
---|
| 561 | if (slen == 0) { |
---|
| 562 | /* |
---|
| 563 | * regsub behavior for "" matches between each character. 'string |
---|
| 564 | * map' skips the "" case. |
---|
| 565 | */ |
---|
| 566 | |
---|
| 567 | if (wstring < wend) { |
---|
| 568 | resultPtr = Tcl_NewUnicodeObj(wstring, 0); |
---|
| 569 | Tcl_IncrRefCount(resultPtr); |
---|
| 570 | for (; wstring < wend; wstring++) { |
---|
| 571 | Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); |
---|
| 572 | Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); |
---|
| 573 | numMatches++; |
---|
| 574 | } |
---|
| 575 | wlen = 0; |
---|
| 576 | } |
---|
| 577 | } else { |
---|
| 578 | wsrclc = Tcl_UniCharToLower(*wsrc); |
---|
| 579 | for (p = wfirstChar = wstring; wstring < wend; wstring++) { |
---|
| 580 | if ((*wstring == *wsrc || |
---|
| 581 | (nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) && |
---|
| 582 | (slen==1 || (strCmpFn(wstring, wsrc, |
---|
| 583 | (unsigned long) slen) == 0))) { |
---|
| 584 | if (numMatches == 0) { |
---|
| 585 | resultPtr = Tcl_NewUnicodeObj(wstring, 0); |
---|
| 586 | Tcl_IncrRefCount(resultPtr); |
---|
| 587 | } |
---|
| 588 | if (p != wstring) { |
---|
| 589 | Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); |
---|
| 590 | p = wstring + slen; |
---|
| 591 | } else { |
---|
| 592 | p += slen; |
---|
| 593 | } |
---|
| 594 | wstring = p - 1; |
---|
| 595 | |
---|
| 596 | Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); |
---|
| 597 | numMatches++; |
---|
| 598 | } |
---|
| 599 | } |
---|
| 600 | if (numMatches) { |
---|
| 601 | wlen = wfirstChar + wlen - p; |
---|
| 602 | wstring = p; |
---|
| 603 | } |
---|
| 604 | } |
---|
| 605 | objPtr = NULL; |
---|
| 606 | subPtr = NULL; |
---|
| 607 | goto regsubDone; |
---|
| 608 | } |
---|
| 609 | |
---|
| 610 | regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); |
---|
| 611 | if (regExpr == NULL) { |
---|
| 612 | return TCL_ERROR; |
---|
| 613 | } |
---|
| 614 | |
---|
| 615 | /* |
---|
| 616 | * Make sure to avoid problems where the objects are shared. This can |
---|
| 617 | * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. |
---|
| 618 | * [Bug #461322] |
---|
| 619 | */ |
---|
| 620 | |
---|
| 621 | if (objv[1] == objv[0]) { |
---|
| 622 | objPtr = Tcl_DuplicateObj(objv[1]); |
---|
| 623 | } else { |
---|
| 624 | objPtr = objv[1]; |
---|
| 625 | } |
---|
| 626 | wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); |
---|
| 627 | if (objv[2] == objv[0]) { |
---|
| 628 | subPtr = Tcl_DuplicateObj(objv[2]); |
---|
| 629 | } else { |
---|
| 630 | subPtr = objv[2]; |
---|
| 631 | } |
---|
| 632 | wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); |
---|
| 633 | |
---|
| 634 | result = TCL_OK; |
---|
| 635 | |
---|
| 636 | /* |
---|
| 637 | * The following loop is to handle multiple matches within the same source |
---|
| 638 | * string; each iteration handles one match and its corresponding |
---|
| 639 | * substitution. If "-all" hasn't been specified then the loop body only |
---|
| 640 | * gets executed once. We must use 'offset <= wlen' in particular for the |
---|
| 641 | * case where the regexp pattern can match the empty string - this is |
---|
| 642 | * useful when doing, say, 'regsub -- ^ $str ...' when $str might be |
---|
| 643 | * empty. |
---|
| 644 | */ |
---|
| 645 | |
---|
| 646 | numMatches = 0; |
---|
| 647 | for ( ; offset <= wlen; ) { |
---|
| 648 | |
---|
| 649 | /* |
---|
| 650 | * The flags argument is set if string is part of a larger string, so |
---|
| 651 | * that "^" won't match. |
---|
| 652 | */ |
---|
| 653 | |
---|
| 654 | match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, |
---|
| 655 | 10 /* matches */, ((offset > 0 && |
---|
| 656 | (wstring[offset-1] != (Tcl_UniChar)'\n')) |
---|
| 657 | ? TCL_REG_NOTBOL : 0)); |
---|
| 658 | |
---|
| 659 | if (match < 0) { |
---|
| 660 | result = TCL_ERROR; |
---|
| 661 | goto done; |
---|
| 662 | } |
---|
| 663 | if (match == 0) { |
---|
| 664 | break; |
---|
| 665 | } |
---|
| 666 | if (numMatches == 0) { |
---|
| 667 | resultPtr = Tcl_NewUnicodeObj(wstring, 0); |
---|
| 668 | Tcl_IncrRefCount(resultPtr); |
---|
| 669 | if (offset > 0) { |
---|
| 670 | /* |
---|
| 671 | * Copy the initial portion of the string in if an offset was |
---|
| 672 | * specified. |
---|
| 673 | */ |
---|
| 674 | |
---|
| 675 | Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); |
---|
| 676 | } |
---|
| 677 | } |
---|
| 678 | numMatches++; |
---|
| 679 | |
---|
| 680 | /* |
---|
| 681 | * Copy the portion of the source string before the match to the |
---|
| 682 | * result variable. |
---|
| 683 | */ |
---|
| 684 | |
---|
| 685 | Tcl_RegExpGetInfo(regExpr, &info); |
---|
| 686 | start = info.matches[0].start; |
---|
| 687 | end = info.matches[0].end; |
---|
| 688 | Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); |
---|
| 689 | |
---|
| 690 | /* |
---|
| 691 | * Append the subSpec argument to the variable, making appropriate |
---|
| 692 | * substitutions. This code is a bit hairy because of the backslash |
---|
| 693 | * conventions and because the code saves up ranges of characters in |
---|
| 694 | * subSpec to reduce the number of calls to Tcl_SetVar. |
---|
| 695 | */ |
---|
| 696 | |
---|
| 697 | wsrc = wfirstChar = wsubspec; |
---|
| 698 | wend = wsubspec + wsublen; |
---|
| 699 | for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) { |
---|
| 700 | if (ch == '&') { |
---|
| 701 | idx = 0; |
---|
| 702 | } else if (ch == '\\') { |
---|
| 703 | ch = wsrc[1]; |
---|
| 704 | if ((ch >= '0') && (ch <= '9')) { |
---|
| 705 | idx = ch - '0'; |
---|
| 706 | } else if ((ch == '\\') || (ch == '&')) { |
---|
| 707 | *wsrc = ch; |
---|
| 708 | Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, |
---|
| 709 | wsrc - wfirstChar + 1); |
---|
| 710 | *wsrc = '\\'; |
---|
| 711 | wfirstChar = wsrc + 2; |
---|
| 712 | wsrc++; |
---|
| 713 | continue; |
---|
| 714 | } else { |
---|
| 715 | continue; |
---|
| 716 | } |
---|
| 717 | } else { |
---|
| 718 | continue; |
---|
| 719 | } |
---|
| 720 | |
---|
| 721 | if (wfirstChar != wsrc) { |
---|
| 722 | Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, |
---|
| 723 | wsrc - wfirstChar); |
---|
| 724 | } |
---|
| 725 | |
---|
| 726 | if (idx <= info.nsubs) { |
---|
| 727 | subStart = info.matches[idx].start; |
---|
| 728 | subEnd = info.matches[idx].end; |
---|
| 729 | if ((subStart >= 0) && (subEnd >= 0)) { |
---|
| 730 | Tcl_AppendUnicodeToObj(resultPtr, |
---|
| 731 | wstring + offset + subStart, subEnd - subStart); |
---|
| 732 | } |
---|
| 733 | } |
---|
| 734 | |
---|
| 735 | if (*wsrc == '\\') { |
---|
| 736 | wsrc++; |
---|
| 737 | } |
---|
| 738 | wfirstChar = wsrc + 1; |
---|
| 739 | } |
---|
| 740 | |
---|
| 741 | if (wfirstChar != wsrc) { |
---|
| 742 | Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); |
---|
| 743 | } |
---|
| 744 | |
---|
| 745 | if (end == 0) { |
---|
| 746 | /* |
---|
| 747 | * Always consume at least one character of the input string in |
---|
| 748 | * order to prevent infinite loops. |
---|
| 749 | */ |
---|
| 750 | |
---|
| 751 | if (offset < wlen) { |
---|
| 752 | Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); |
---|
| 753 | } |
---|
| 754 | offset++; |
---|
| 755 | } else { |
---|
| 756 | offset += end; |
---|
| 757 | if (start == end) { |
---|
| 758 | /* |
---|
| 759 | * We matched an empty string, which means we must go forward |
---|
| 760 | * one more step so we don't match again at the same spot. |
---|
| 761 | */ |
---|
| 762 | |
---|
| 763 | if (offset < wlen) { |
---|
| 764 | Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); |
---|
| 765 | } |
---|
| 766 | offset++; |
---|
| 767 | } |
---|
| 768 | } |
---|
| 769 | if (!all) { |
---|
| 770 | break; |
---|
| 771 | } |
---|
| 772 | } |
---|
| 773 | |
---|
| 774 | /* |
---|
| 775 | * Copy the portion of the source string after the last match to the |
---|
| 776 | * result variable. |
---|
| 777 | */ |
---|
| 778 | |
---|
| 779 | regsubDone: |
---|
| 780 | if (numMatches == 0) { |
---|
| 781 | /* |
---|
| 782 | * On zero matches, just ignore the offset, since it shouldn't matter |
---|
| 783 | * to us in this case, and the user may have skewed it. |
---|
| 784 | */ |
---|
| 785 | |
---|
| 786 | resultPtr = objv[1]; |
---|
| 787 | Tcl_IncrRefCount(resultPtr); |
---|
| 788 | } else if (offset < wlen) { |
---|
| 789 | Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); |
---|
| 790 | } |
---|
| 791 | if (objc == 4) { |
---|
| 792 | if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { |
---|
| 793 | Tcl_AppendResult(interp, "couldn't set variable \"", |
---|
| 794 | TclGetString(objv[3]), "\"", NULL); |
---|
| 795 | result = TCL_ERROR; |
---|
| 796 | } else { |
---|
| 797 | /* |
---|
| 798 | * Set the interpreter's object result to an integer object |
---|
| 799 | * holding the number of matches. |
---|
| 800 | */ |
---|
| 801 | |
---|
| 802 | Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches)); |
---|
| 803 | } |
---|
| 804 | } else { |
---|
| 805 | /* |
---|
| 806 | * No varname supplied, so just return the modified string. |
---|
| 807 | */ |
---|
| 808 | |
---|
| 809 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 810 | } |
---|
| 811 | |
---|
| 812 | done: |
---|
| 813 | if (objPtr && (objv[1] == objv[0])) { |
---|
| 814 | Tcl_DecrRefCount(objPtr); |
---|
| 815 | } |
---|
| 816 | if (subPtr && (objv[2] == objv[0])) { |
---|
| 817 | Tcl_DecrRefCount(subPtr); |
---|
| 818 | } |
---|
| 819 | if (resultPtr) { |
---|
| 820 | Tcl_DecrRefCount(resultPtr); |
---|
| 821 | } |
---|
| 822 | return result; |
---|
| 823 | } |
---|
| 824 | |
---|
| 825 | /* |
---|
| 826 | *---------------------------------------------------------------------- |
---|
| 827 | * |
---|
| 828 | * Tcl_RenameObjCmd -- |
---|
| 829 | * |
---|
| 830 | * This procedure is invoked to process the "rename" Tcl command. See the |
---|
| 831 | * user documentation for details on what it does. |
---|
| 832 | * |
---|
| 833 | * Results: |
---|
| 834 | * A standard Tcl object result. |
---|
| 835 | * |
---|
| 836 | * Side effects: |
---|
| 837 | * See the user documentation. |
---|
| 838 | * |
---|
| 839 | *---------------------------------------------------------------------- |
---|
| 840 | */ |
---|
| 841 | |
---|
| 842 | int |
---|
| 843 | Tcl_RenameObjCmd( |
---|
| 844 | ClientData dummy, /* Arbitrary value passed to the command. */ |
---|
| 845 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 846 | int objc, /* Number of arguments. */ |
---|
| 847 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 848 | { |
---|
| 849 | char *oldName, *newName; |
---|
| 850 | |
---|
| 851 | if (objc != 3) { |
---|
| 852 | Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); |
---|
| 853 | return TCL_ERROR; |
---|
| 854 | } |
---|
| 855 | |
---|
| 856 | oldName = TclGetString(objv[1]); |
---|
| 857 | newName = TclGetString(objv[2]); |
---|
| 858 | return TclRenameCommand(interp, oldName, newName); |
---|
| 859 | } |
---|
| 860 | |
---|
| 861 | /* |
---|
| 862 | *---------------------------------------------------------------------- |
---|
| 863 | * |
---|
| 864 | * Tcl_ReturnObjCmd -- |
---|
| 865 | * |
---|
| 866 | * This object-based procedure is invoked to process the "return" Tcl |
---|
| 867 | * command. See the user documentation for details on what it does. |
---|
| 868 | * |
---|
| 869 | * Results: |
---|
| 870 | * A standard Tcl object result. |
---|
| 871 | * |
---|
| 872 | * Side effects: |
---|
| 873 | * See the user documentation. |
---|
| 874 | * |
---|
| 875 | *---------------------------------------------------------------------- |
---|
| 876 | */ |
---|
| 877 | |
---|
| 878 | int |
---|
| 879 | Tcl_ReturnObjCmd( |
---|
| 880 | ClientData dummy, /* Not used. */ |
---|
| 881 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 882 | int objc, /* Number of arguments. */ |
---|
| 883 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 884 | { |
---|
| 885 | int code, level; |
---|
| 886 | Tcl_Obj *returnOpts; |
---|
| 887 | |
---|
| 888 | /* |
---|
| 889 | * General syntax: [return ?-option value ...? ?result?] |
---|
| 890 | * An even number of words means an explicit result argument is present. |
---|
| 891 | */ |
---|
| 892 | |
---|
| 893 | int explicitResult = (0 == (objc % 2)); |
---|
| 894 | int numOptionWords = objc - 1 - explicitResult; |
---|
| 895 | |
---|
| 896 | if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1, |
---|
| 897 | &returnOpts, &code, &level)) { |
---|
| 898 | return TCL_ERROR; |
---|
| 899 | } |
---|
| 900 | |
---|
| 901 | code = TclProcessReturn(interp, code, level, returnOpts); |
---|
| 902 | if (explicitResult) { |
---|
| 903 | Tcl_SetObjResult(interp, objv[objc-1]); |
---|
| 904 | } |
---|
| 905 | return code; |
---|
| 906 | } |
---|
| 907 | |
---|
| 908 | /* |
---|
| 909 | *---------------------------------------------------------------------- |
---|
| 910 | * |
---|
| 911 | * Tcl_SourceObjCmd -- |
---|
| 912 | * |
---|
| 913 | * This procedure is invoked to process the "source" Tcl command. See the |
---|
| 914 | * user documentation for details on what it does. |
---|
| 915 | * |
---|
| 916 | * Results: |
---|
| 917 | * A standard Tcl object result. |
---|
| 918 | * |
---|
| 919 | * Side effects: |
---|
| 920 | * See the user documentation. |
---|
| 921 | * |
---|
| 922 | *---------------------------------------------------------------------- |
---|
| 923 | */ |
---|
| 924 | |
---|
| 925 | int |
---|
| 926 | Tcl_SourceObjCmd( |
---|
| 927 | ClientData dummy, /* Not used. */ |
---|
| 928 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 929 | int objc, /* Number of arguments. */ |
---|
| 930 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 931 | { |
---|
| 932 | CONST char *encodingName = NULL; |
---|
| 933 | Tcl_Obj *fileName; |
---|
| 934 | |
---|
| 935 | if (objc != 2 && objc !=4) { |
---|
| 936 | Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); |
---|
| 937 | return TCL_ERROR; |
---|
| 938 | } |
---|
| 939 | |
---|
| 940 | fileName = objv[objc-1]; |
---|
| 941 | |
---|
| 942 | if (objc == 4) { |
---|
| 943 | static CONST char *options[] = { |
---|
| 944 | "-encoding", NULL |
---|
| 945 | }; |
---|
| 946 | int index; |
---|
| 947 | |
---|
| 948 | if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, |
---|
| 949 | "option", TCL_EXACT, &index)) { |
---|
| 950 | return TCL_ERROR; |
---|
| 951 | } |
---|
| 952 | encodingName = TclGetString(objv[2]); |
---|
| 953 | } |
---|
| 954 | |
---|
| 955 | return Tcl_FSEvalFileEx(interp, fileName, encodingName); |
---|
| 956 | } |
---|
| 957 | |
---|
| 958 | /* |
---|
| 959 | *---------------------------------------------------------------------- |
---|
| 960 | * |
---|
| 961 | * Tcl_SplitObjCmd -- |
---|
| 962 | * |
---|
| 963 | * This procedure is invoked to process the "split" Tcl command. See the |
---|
| 964 | * user documentation for details on what it does. |
---|
| 965 | * |
---|
| 966 | * Results: |
---|
| 967 | * A standard Tcl result. |
---|
| 968 | * |
---|
| 969 | * Side effects: |
---|
| 970 | * See the user documentation. |
---|
| 971 | * |
---|
| 972 | *---------------------------------------------------------------------- |
---|
| 973 | */ |
---|
| 974 | |
---|
| 975 | int |
---|
| 976 | Tcl_SplitObjCmd( |
---|
| 977 | ClientData dummy, /* Not used. */ |
---|
| 978 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 979 | int objc, /* Number of arguments. */ |
---|
| 980 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 981 | { |
---|
| 982 | Tcl_UniChar ch; |
---|
| 983 | int len; |
---|
| 984 | char *splitChars, *stringPtr, *end; |
---|
| 985 | int splitCharLen, stringLen; |
---|
| 986 | Tcl_Obj *listPtr, *objPtr; |
---|
| 987 | |
---|
| 988 | if (objc == 2) { |
---|
| 989 | splitChars = " \n\t\r"; |
---|
| 990 | splitCharLen = 4; |
---|
| 991 | } else if (objc == 3) { |
---|
| 992 | splitChars = TclGetStringFromObj(objv[2], &splitCharLen); |
---|
| 993 | } else { |
---|
| 994 | Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); |
---|
| 995 | return TCL_ERROR; |
---|
| 996 | } |
---|
| 997 | |
---|
| 998 | stringPtr = TclGetStringFromObj(objv[1], &stringLen); |
---|
| 999 | end = stringPtr + stringLen; |
---|
| 1000 | listPtr = Tcl_NewObj(); |
---|
| 1001 | |
---|
| 1002 | if (stringLen == 0) { |
---|
| 1003 | /* |
---|
| 1004 | * Do nothing. |
---|
| 1005 | */ |
---|
| 1006 | } else if (splitCharLen == 0) { |
---|
| 1007 | Tcl_HashTable charReuseTable; |
---|
| 1008 | Tcl_HashEntry *hPtr; |
---|
| 1009 | int isNew; |
---|
| 1010 | |
---|
| 1011 | /* |
---|
| 1012 | * Handle the special case of splitting on every character. |
---|
| 1013 | * |
---|
| 1014 | * Uses a hash table to ensure that each kind of character has only |
---|
| 1015 | * one Tcl_Obj instance (multiply-referenced) in the final list. This |
---|
| 1016 | * is a *major* win when splitting on a long string (especially in the |
---|
| 1017 | * megabyte range!) - DKF |
---|
| 1018 | */ |
---|
| 1019 | |
---|
| 1020 | Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); |
---|
| 1021 | |
---|
| 1022 | for ( ; stringPtr < end; stringPtr += len) { |
---|
| 1023 | len = TclUtfToUniChar(stringPtr, &ch); |
---|
| 1024 | |
---|
| 1025 | /* |
---|
| 1026 | * Assume Tcl_UniChar is an integral type... |
---|
| 1027 | */ |
---|
| 1028 | |
---|
| 1029 | hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0+ch, &isNew); |
---|
| 1030 | if (isNew) { |
---|
| 1031 | TclNewStringObj(objPtr, stringPtr, len); |
---|
| 1032 | |
---|
| 1033 | /* |
---|
| 1034 | * Don't need to fiddle with refcount... |
---|
| 1035 | */ |
---|
| 1036 | |
---|
| 1037 | Tcl_SetHashValue(hPtr, (ClientData) objPtr); |
---|
| 1038 | } else { |
---|
| 1039 | objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); |
---|
| 1040 | } |
---|
| 1041 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); |
---|
| 1042 | } |
---|
| 1043 | Tcl_DeleteHashTable(&charReuseTable); |
---|
| 1044 | |
---|
| 1045 | } else if (splitCharLen == 1) { |
---|
| 1046 | char *p; |
---|
| 1047 | |
---|
| 1048 | /* |
---|
| 1049 | * Handle the special case of splitting on a single character. This is |
---|
| 1050 | * only true for the one-char ASCII case, as one unicode char is > 1 |
---|
| 1051 | * byte in length. |
---|
| 1052 | */ |
---|
| 1053 | |
---|
| 1054 | while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) { |
---|
| 1055 | objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr); |
---|
| 1056 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); |
---|
| 1057 | stringPtr = p + 1; |
---|
| 1058 | } |
---|
| 1059 | TclNewStringObj(objPtr, stringPtr, end - stringPtr); |
---|
| 1060 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); |
---|
| 1061 | } else { |
---|
| 1062 | char *element, *p, *splitEnd; |
---|
| 1063 | int splitLen; |
---|
| 1064 | Tcl_UniChar splitChar; |
---|
| 1065 | |
---|
| 1066 | /* |
---|
| 1067 | * Normal case: split on any of a given set of characters. Discard |
---|
| 1068 | * instances of the split characters. |
---|
| 1069 | */ |
---|
| 1070 | |
---|
| 1071 | splitEnd = splitChars + splitCharLen; |
---|
| 1072 | |
---|
| 1073 | for (element = stringPtr; stringPtr < end; stringPtr += len) { |
---|
| 1074 | len = TclUtfToUniChar(stringPtr, &ch); |
---|
| 1075 | for (p = splitChars; p < splitEnd; p += splitLen) { |
---|
| 1076 | splitLen = TclUtfToUniChar(p, &splitChar); |
---|
| 1077 | if (ch == splitChar) { |
---|
| 1078 | TclNewStringObj(objPtr, element, stringPtr - element); |
---|
| 1079 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); |
---|
| 1080 | element = stringPtr + len; |
---|
| 1081 | break; |
---|
| 1082 | } |
---|
| 1083 | } |
---|
| 1084 | } |
---|
| 1085 | |
---|
| 1086 | TclNewStringObj(objPtr, element, stringPtr - element); |
---|
| 1087 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); |
---|
| 1088 | } |
---|
| 1089 | Tcl_SetObjResult(interp, listPtr); |
---|
| 1090 | return TCL_OK; |
---|
| 1091 | } |
---|
| 1092 | |
---|
| 1093 | /* |
---|
| 1094 | *---------------------------------------------------------------------- |
---|
| 1095 | * |
---|
| 1096 | * StringFirstCmd -- |
---|
| 1097 | * |
---|
| 1098 | * This procedure is invoked to process the "string first" Tcl command. |
---|
| 1099 | * See the user documentation for details on what it does. Note that this |
---|
| 1100 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 1101 | * |
---|
| 1102 | * Results: |
---|
| 1103 | * A standard Tcl result. |
---|
| 1104 | * |
---|
| 1105 | * Side effects: |
---|
| 1106 | * See the user documentation. |
---|
| 1107 | * |
---|
| 1108 | *---------------------------------------------------------------------- |
---|
| 1109 | */ |
---|
| 1110 | |
---|
| 1111 | static int |
---|
| 1112 | StringFirstCmd( |
---|
| 1113 | ClientData dummy, /* Not used. */ |
---|
| 1114 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 1115 | int objc, /* Number of arguments. */ |
---|
| 1116 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 1117 | { |
---|
| 1118 | Tcl_UniChar *ustring1, *ustring2; |
---|
| 1119 | int match, start, length1, length2; |
---|
| 1120 | |
---|
| 1121 | if (objc < 3 || objc > 4) { |
---|
| 1122 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 1123 | "needleString haystackString ?startIndex?"); |
---|
| 1124 | return TCL_ERROR; |
---|
| 1125 | } |
---|
| 1126 | |
---|
| 1127 | /* |
---|
| 1128 | * We are searching string2 for the sequence string1. |
---|
| 1129 | */ |
---|
| 1130 | |
---|
| 1131 | match = -1; |
---|
| 1132 | start = 0; |
---|
| 1133 | length2 = -1; |
---|
| 1134 | |
---|
| 1135 | ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); |
---|
| 1136 | ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); |
---|
| 1137 | |
---|
| 1138 | if (objc == 4) { |
---|
| 1139 | /* |
---|
| 1140 | * If a startIndex is specified, we will need to fast forward to that |
---|
| 1141 | * point in the string before we think about a match. |
---|
| 1142 | */ |
---|
| 1143 | |
---|
| 1144 | if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ |
---|
| 1145 | return TCL_ERROR; |
---|
| 1146 | } |
---|
| 1147 | |
---|
| 1148 | /* |
---|
| 1149 | * Reread to prevent shimmering problems. |
---|
| 1150 | */ |
---|
| 1151 | |
---|
| 1152 | ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); |
---|
| 1153 | ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); |
---|
| 1154 | |
---|
| 1155 | if (start >= length2) { |
---|
| 1156 | goto str_first_done; |
---|
| 1157 | } else if (start > 0) { |
---|
| 1158 | ustring2 += start; |
---|
| 1159 | length2 -= start; |
---|
| 1160 | } else if (start < 0) { |
---|
| 1161 | /* |
---|
| 1162 | * Invalid start index mapped to string start; Bug #423581 |
---|
| 1163 | */ |
---|
| 1164 | |
---|
| 1165 | start = 0; |
---|
| 1166 | } |
---|
| 1167 | } |
---|
| 1168 | |
---|
| 1169 | if (length1 > 0) { |
---|
| 1170 | register Tcl_UniChar *p, *end; |
---|
| 1171 | |
---|
| 1172 | end = ustring2 + length2 - length1 + 1; |
---|
| 1173 | for (p = ustring2; p < end; p++) { |
---|
| 1174 | /* |
---|
| 1175 | * Scan forward to find the first character. |
---|
| 1176 | */ |
---|
| 1177 | |
---|
| 1178 | if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p, |
---|
| 1179 | (unsigned long) length1) == 0)) { |
---|
| 1180 | match = p - ustring2; |
---|
| 1181 | break; |
---|
| 1182 | } |
---|
| 1183 | } |
---|
| 1184 | } |
---|
| 1185 | |
---|
| 1186 | /* |
---|
| 1187 | * Compute the character index of the matching string by counting the |
---|
| 1188 | * number of characters before the match. |
---|
| 1189 | */ |
---|
| 1190 | |
---|
| 1191 | if ((match != -1) && (objc == 4)) { |
---|
| 1192 | match += start; |
---|
| 1193 | } |
---|
| 1194 | |
---|
| 1195 | str_first_done: |
---|
| 1196 | Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); |
---|
| 1197 | return TCL_OK; |
---|
| 1198 | } |
---|
| 1199 | |
---|
| 1200 | /* |
---|
| 1201 | *---------------------------------------------------------------------- |
---|
| 1202 | * |
---|
| 1203 | * StringLastCmd -- |
---|
| 1204 | * |
---|
| 1205 | * This procedure is invoked to process the "string last" Tcl command. |
---|
| 1206 | * See the user documentation for details on what it does. Note that this |
---|
| 1207 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 1208 | * |
---|
| 1209 | * Results: |
---|
| 1210 | * A standard Tcl result. |
---|
| 1211 | * |
---|
| 1212 | * Side effects: |
---|
| 1213 | * See the user documentation. |
---|
| 1214 | * |
---|
| 1215 | *---------------------------------------------------------------------- |
---|
| 1216 | */ |
---|
| 1217 | |
---|
| 1218 | static int |
---|
| 1219 | StringLastCmd( |
---|
| 1220 | ClientData dummy, /* Not used. */ |
---|
| 1221 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 1222 | int objc, /* Number of arguments. */ |
---|
| 1223 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 1224 | { |
---|
| 1225 | Tcl_UniChar *ustring1, *ustring2, *p; |
---|
| 1226 | int match, start, length1, length2; |
---|
| 1227 | |
---|
| 1228 | if (objc < 3 || objc > 4) { |
---|
| 1229 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 1230 | "needleString haystackString ?startIndex?"); |
---|
| 1231 | return TCL_ERROR; |
---|
| 1232 | } |
---|
| 1233 | |
---|
| 1234 | /* |
---|
| 1235 | * We are searching string2 for the sequence string1. |
---|
| 1236 | */ |
---|
| 1237 | |
---|
| 1238 | match = -1; |
---|
| 1239 | start = 0; |
---|
| 1240 | length2 = -1; |
---|
| 1241 | |
---|
| 1242 | ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); |
---|
| 1243 | ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); |
---|
| 1244 | |
---|
| 1245 | if (objc == 4) { |
---|
| 1246 | /* |
---|
| 1247 | * If a startIndex is specified, we will need to restrict the string |
---|
| 1248 | * range to that char index in the string |
---|
| 1249 | */ |
---|
| 1250 | |
---|
| 1251 | if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ |
---|
| 1252 | return TCL_ERROR; |
---|
| 1253 | } |
---|
| 1254 | |
---|
| 1255 | /* |
---|
| 1256 | * Reread to prevent shimmering problems. |
---|
| 1257 | */ |
---|
| 1258 | |
---|
| 1259 | ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); |
---|
| 1260 | ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); |
---|
| 1261 | |
---|
| 1262 | if (start < 0) { |
---|
| 1263 | goto str_last_done; |
---|
| 1264 | } else if (start < length2) { |
---|
| 1265 | p = ustring2 + start + 1 - length1; |
---|
| 1266 | } else { |
---|
| 1267 | p = ustring2 + length2 - length1; |
---|
| 1268 | } |
---|
| 1269 | } else { |
---|
| 1270 | p = ustring2 + length2 - length1; |
---|
| 1271 | } |
---|
| 1272 | |
---|
| 1273 | if (length1 > 0) { |
---|
| 1274 | for (; p >= ustring2; p--) { |
---|
| 1275 | /* |
---|
| 1276 | * Scan backwards to find the first character. |
---|
| 1277 | */ |
---|
| 1278 | |
---|
| 1279 | if ((*p == *ustring1) && !memcmp(ustring1, p, |
---|
| 1280 | sizeof(Tcl_UniChar) * (size_t)length1)) { |
---|
| 1281 | match = p - ustring2; |
---|
| 1282 | break; |
---|
| 1283 | } |
---|
| 1284 | } |
---|
| 1285 | } |
---|
| 1286 | |
---|
| 1287 | str_last_done: |
---|
| 1288 | Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); |
---|
| 1289 | return TCL_OK; |
---|
| 1290 | } |
---|
| 1291 | |
---|
| 1292 | /* |
---|
| 1293 | *---------------------------------------------------------------------- |
---|
| 1294 | * |
---|
| 1295 | * StringIndexCmd -- |
---|
| 1296 | * |
---|
| 1297 | * This procedure is invoked to process the "string index" Tcl command. |
---|
| 1298 | * See the user documentation for details on what it does. Note that this |
---|
| 1299 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 1300 | * |
---|
| 1301 | * Results: |
---|
| 1302 | * A standard Tcl result. |
---|
| 1303 | * |
---|
| 1304 | * Side effects: |
---|
| 1305 | * See the user documentation. |
---|
| 1306 | * |
---|
| 1307 | *---------------------------------------------------------------------- |
---|
| 1308 | */ |
---|
| 1309 | |
---|
| 1310 | static int |
---|
| 1311 | StringIndexCmd( |
---|
| 1312 | ClientData dummy, /* Not used. */ |
---|
| 1313 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 1314 | int objc, /* Number of arguments. */ |
---|
| 1315 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 1316 | { |
---|
| 1317 | int length, index; |
---|
| 1318 | |
---|
| 1319 | if (objc != 3) { |
---|
| 1320 | Tcl_WrongNumArgs(interp, 1, objv, "string charIndex"); |
---|
| 1321 | return TCL_ERROR; |
---|
| 1322 | } |
---|
| 1323 | |
---|
| 1324 | /* |
---|
| 1325 | * If we have a ByteArray object, avoid indexing in the Utf string since |
---|
| 1326 | * the byte array contains one byte per character. Otherwise, use the |
---|
| 1327 | * Unicode string rep to get the index'th char. |
---|
| 1328 | */ |
---|
| 1329 | |
---|
| 1330 | if (objv[1]->typePtr == &tclByteArrayType) { |
---|
| 1331 | const unsigned char *string = |
---|
| 1332 | Tcl_GetByteArrayFromObj(objv[1], &length); |
---|
| 1333 | |
---|
| 1334 | if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){ |
---|
| 1335 | return TCL_ERROR; |
---|
| 1336 | } |
---|
| 1337 | string = Tcl_GetByteArrayFromObj(objv[1], &length); |
---|
| 1338 | if ((index >= 0) && (index < length)) { |
---|
| 1339 | Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(string + index, 1)); |
---|
| 1340 | } |
---|
| 1341 | } else { |
---|
| 1342 | /* |
---|
| 1343 | * Get Unicode char length to calulate what 'end' means. |
---|
| 1344 | */ |
---|
| 1345 | |
---|
| 1346 | length = Tcl_GetCharLength(objv[1]); |
---|
| 1347 | |
---|
| 1348 | if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){ |
---|
| 1349 | return TCL_ERROR; |
---|
| 1350 | } |
---|
| 1351 | if ((index >= 0) && (index < length)) { |
---|
| 1352 | char buf[TCL_UTF_MAX]; |
---|
| 1353 | Tcl_UniChar ch; |
---|
| 1354 | |
---|
| 1355 | ch = Tcl_GetUniChar(objv[1], index); |
---|
| 1356 | length = Tcl_UniCharToUtf(ch, buf); |
---|
| 1357 | Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); |
---|
| 1358 | } |
---|
| 1359 | } |
---|
| 1360 | return TCL_OK; |
---|
| 1361 | } |
---|
| 1362 | |
---|
| 1363 | /* |
---|
| 1364 | *---------------------------------------------------------------------- |
---|
| 1365 | * |
---|
| 1366 | * StringIsCmd -- |
---|
| 1367 | * |
---|
| 1368 | * This procedure is invoked to process the "string is" Tcl command. See |
---|
| 1369 | * the user documentation for details on what it does. Note that this |
---|
| 1370 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 1371 | * |
---|
| 1372 | * Results: |
---|
| 1373 | * A standard Tcl result. |
---|
| 1374 | * |
---|
| 1375 | * Side effects: |
---|
| 1376 | * See the user documentation. |
---|
| 1377 | * |
---|
| 1378 | *---------------------------------------------------------------------- |
---|
| 1379 | */ |
---|
| 1380 | |
---|
| 1381 | static int |
---|
| 1382 | StringIsCmd( |
---|
| 1383 | ClientData dummy, /* Not used. */ |
---|
| 1384 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 1385 | int objc, /* Number of arguments. */ |
---|
| 1386 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 1387 | { |
---|
| 1388 | const char *string1, *string2, *end, *stop; |
---|
| 1389 | Tcl_UniChar ch; |
---|
| 1390 | int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ |
---|
| 1391 | int i, failat = 0, result = 1, strict = 0, index, length1, length2; |
---|
| 1392 | Tcl_Obj *objPtr, *failVarObj = NULL; |
---|
| 1393 | Tcl_WideInt w; |
---|
| 1394 | |
---|
| 1395 | static const char *isOptions[] = { |
---|
| 1396 | "alnum", "alpha", "ascii", "control", |
---|
| 1397 | "boolean", "digit", "double", "false", |
---|
| 1398 | "graph", "integer", "list", "lower", |
---|
| 1399 | "print", "punct", "space", "true", |
---|
| 1400 | "upper", "wideinteger", "wordchar", "xdigit", |
---|
| 1401 | NULL |
---|
| 1402 | }; |
---|
| 1403 | enum isOptions { |
---|
| 1404 | STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, |
---|
| 1405 | STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, |
---|
| 1406 | STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER, |
---|
| 1407 | STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, |
---|
| 1408 | STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT |
---|
| 1409 | }; |
---|
| 1410 | |
---|
| 1411 | if (objc < 3 || objc > 6) { |
---|
| 1412 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 1413 | "class ?-strict? ?-failindex var? str"); |
---|
| 1414 | return TCL_ERROR; |
---|
| 1415 | } |
---|
| 1416 | if (Tcl_GetIndexFromObj(interp, objv[1], isOptions, "class", 0, |
---|
| 1417 | &index) != TCL_OK) { |
---|
| 1418 | return TCL_ERROR; |
---|
| 1419 | } |
---|
| 1420 | |
---|
| 1421 | if (objc != 3) { |
---|
| 1422 | for (i = 2; i < objc-1; i++) { |
---|
| 1423 | string2 = TclGetStringFromObj(objv[i], &length2); |
---|
| 1424 | if ((length2 > 1) && |
---|
| 1425 | strncmp(string2, "-strict", (size_t) length2) == 0) { |
---|
| 1426 | strict = 1; |
---|
| 1427 | } else if ((length2 > 1) && |
---|
| 1428 | strncmp(string2, "-failindex", (size_t)length2) == 0){ |
---|
| 1429 | if (i+1 >= objc-1) { |
---|
| 1430 | Tcl_WrongNumArgs(interp, 2, objv, |
---|
| 1431 | "?-strict? ?-failindex var? str"); |
---|
| 1432 | return TCL_ERROR; |
---|
| 1433 | } |
---|
| 1434 | failVarObj = objv[++i]; |
---|
| 1435 | } else { |
---|
| 1436 | Tcl_AppendResult(interp, "bad option \"", string2, |
---|
| 1437 | "\": must be -strict or -failindex", NULL); |
---|
| 1438 | return TCL_ERROR; |
---|
| 1439 | } |
---|
| 1440 | } |
---|
| 1441 | } |
---|
| 1442 | |
---|
| 1443 | /* |
---|
| 1444 | * We get the objPtr so that we can short-cut for some classes by checking |
---|
| 1445 | * the object type (int and double), but we need the string otherwise, |
---|
| 1446 | * because we don't want any conversion of type occuring (as, for example, |
---|
| 1447 | * Tcl_Get*FromObj would do). |
---|
| 1448 | */ |
---|
| 1449 | |
---|
| 1450 | objPtr = objv[objc-1]; |
---|
| 1451 | string1 = TclGetStringFromObj(objPtr, &length1); |
---|
| 1452 | if (length1 == 0 && index != STR_IS_LIST) { |
---|
| 1453 | if (strict) { |
---|
| 1454 | result = 0; |
---|
| 1455 | } |
---|
| 1456 | goto str_is_done; |
---|
| 1457 | } |
---|
| 1458 | end = string1 + length1; |
---|
| 1459 | |
---|
| 1460 | /* |
---|
| 1461 | * When entering here, result == 1 and failat == 0. |
---|
| 1462 | */ |
---|
| 1463 | |
---|
| 1464 | switch ((enum isOptions) index) { |
---|
| 1465 | case STR_IS_ALNUM: |
---|
| 1466 | chcomp = Tcl_UniCharIsAlnum; |
---|
| 1467 | break; |
---|
| 1468 | case STR_IS_ALPHA: |
---|
| 1469 | chcomp = Tcl_UniCharIsAlpha; |
---|
| 1470 | break; |
---|
| 1471 | case STR_IS_ASCII: |
---|
| 1472 | chcomp = UniCharIsAscii; |
---|
| 1473 | break; |
---|
| 1474 | case STR_IS_BOOL: |
---|
| 1475 | case STR_IS_TRUE: |
---|
| 1476 | case STR_IS_FALSE: |
---|
| 1477 | if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { |
---|
| 1478 | result = 0; |
---|
| 1479 | } else if (((index == STR_IS_TRUE) && |
---|
| 1480 | objPtr->internalRep.longValue == 0) |
---|
| 1481 | || ((index == STR_IS_FALSE) && |
---|
| 1482 | objPtr->internalRep.longValue != 0)) { |
---|
| 1483 | result = 0; |
---|
| 1484 | } |
---|
| 1485 | break; |
---|
| 1486 | case STR_IS_CONTROL: |
---|
| 1487 | chcomp = Tcl_UniCharIsControl; |
---|
| 1488 | break; |
---|
| 1489 | case STR_IS_DIGIT: |
---|
| 1490 | chcomp = Tcl_UniCharIsDigit; |
---|
| 1491 | break; |
---|
| 1492 | case STR_IS_DOUBLE: { |
---|
| 1493 | /* TODO */ |
---|
| 1494 | if ((objPtr->typePtr == &tclDoubleType) || |
---|
| 1495 | (objPtr->typePtr == &tclIntType) || |
---|
| 1496 | #ifndef NO_WIDE_TYPE |
---|
| 1497 | (objPtr->typePtr == &tclWideIntType) || |
---|
| 1498 | #endif |
---|
| 1499 | (objPtr->typePtr == &tclBignumType)) { |
---|
| 1500 | break; |
---|
| 1501 | } |
---|
| 1502 | if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, |
---|
| 1503 | (const char **) &stop, 0) != TCL_OK) { |
---|
| 1504 | result = 0; |
---|
| 1505 | failat = 0; |
---|
| 1506 | } else { |
---|
| 1507 | failat = stop - string1; |
---|
| 1508 | if (stop < end) { |
---|
| 1509 | result = 0; |
---|
| 1510 | TclFreeIntRep(objPtr); |
---|
| 1511 | objPtr->typePtr = NULL; |
---|
| 1512 | } |
---|
| 1513 | } |
---|
| 1514 | break; |
---|
| 1515 | } |
---|
| 1516 | case STR_IS_GRAPH: |
---|
| 1517 | chcomp = Tcl_UniCharIsGraph; |
---|
| 1518 | break; |
---|
| 1519 | case STR_IS_INT: |
---|
| 1520 | if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { |
---|
| 1521 | break; |
---|
| 1522 | } |
---|
| 1523 | goto failedIntParse; |
---|
| 1524 | case STR_IS_WIDE: |
---|
| 1525 | if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { |
---|
| 1526 | break; |
---|
| 1527 | } |
---|
| 1528 | |
---|
| 1529 | failedIntParse: |
---|
| 1530 | result = 0; |
---|
| 1531 | |
---|
| 1532 | if (failVarObj == NULL) { |
---|
| 1533 | /* |
---|
| 1534 | * Don't bother computing the failure point if we're not going to |
---|
| 1535 | * return it. |
---|
| 1536 | */ |
---|
| 1537 | |
---|
| 1538 | break; |
---|
| 1539 | } |
---|
| 1540 | if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, |
---|
| 1541 | (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { |
---|
| 1542 | if (stop == end) { |
---|
| 1543 | /* |
---|
| 1544 | * Entire string parses as an integer, but rejected by |
---|
| 1545 | * Tcl_Get(Wide)IntFromObj() so we must have overflowed the |
---|
| 1546 | * target type, and our convention is to return failure at |
---|
| 1547 | * index -1 in that situation. |
---|
| 1548 | */ |
---|
| 1549 | |
---|
| 1550 | failat = -1; |
---|
| 1551 | } else { |
---|
| 1552 | /* |
---|
| 1553 | * Some prefix parsed as an integer, but not the whole string, |
---|
| 1554 | * so return failure index as the point where parsing stopped. |
---|
| 1555 | * Clear out the internal rep, since keeping it would leave |
---|
| 1556 | * *objPtr in an inconsistent state. |
---|
| 1557 | */ |
---|
| 1558 | |
---|
| 1559 | failat = stop - string1; |
---|
| 1560 | TclFreeIntRep(objPtr); |
---|
| 1561 | objPtr->typePtr = NULL; |
---|
| 1562 | } |
---|
| 1563 | } else { |
---|
| 1564 | /* |
---|
| 1565 | * No prefix is a valid integer. Fail at beginning. |
---|
| 1566 | */ |
---|
| 1567 | |
---|
| 1568 | failat = 0; |
---|
| 1569 | } |
---|
| 1570 | break; |
---|
| 1571 | case STR_IS_LIST: |
---|
| 1572 | /* |
---|
| 1573 | * We ignore the strictness here, since empty strings are always |
---|
| 1574 | * well-formed lists. |
---|
| 1575 | */ |
---|
| 1576 | |
---|
| 1577 | if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) { |
---|
| 1578 | break; |
---|
| 1579 | } |
---|
| 1580 | |
---|
| 1581 | if (failVarObj != NULL) { |
---|
| 1582 | /* |
---|
| 1583 | * Need to figure out where the list parsing failed, which is |
---|
| 1584 | * fairly expensive. This is adapted from the core of |
---|
| 1585 | * SetListFromAny(). |
---|
| 1586 | */ |
---|
| 1587 | |
---|
| 1588 | const char *elemStart, *nextElem, *limit; |
---|
| 1589 | int lenRemain, elemSize, hasBrace; |
---|
| 1590 | register const char *p; |
---|
| 1591 | |
---|
| 1592 | limit = string1 + length1; |
---|
| 1593 | failat = -1; |
---|
| 1594 | for (p=string1, lenRemain=length1; lenRemain > 0; |
---|
| 1595 | p=nextElem, lenRemain=limit-nextElem) { |
---|
| 1596 | if (TCL_ERROR == TclFindElement(NULL, p, lenRemain, |
---|
| 1597 | &elemStart, &nextElem, &elemSize, &hasBrace)) { |
---|
| 1598 | Tcl_Obj *tmpStr; |
---|
| 1599 | |
---|
| 1600 | /* |
---|
| 1601 | * This is the simplest way of getting the number of |
---|
| 1602 | * characters parsed. Note that this is not the same as |
---|
| 1603 | * the number of bytes when parsing strings with non-ASCII |
---|
| 1604 | * characters in them. |
---|
| 1605 | * |
---|
| 1606 | * Skip leading spaces first. This is only really an issue |
---|
| 1607 | * if it is the first "element" that has the failure. |
---|
| 1608 | */ |
---|
| 1609 | |
---|
| 1610 | while (isspace(UCHAR(*p))) { /* INTL: ? */ |
---|
| 1611 | p++; |
---|
| 1612 | } |
---|
| 1613 | TclNewStringObj(tmpStr, string1, p-string1); |
---|
| 1614 | failat = Tcl_GetCharLength(tmpStr); |
---|
| 1615 | TclDecrRefCount(tmpStr); |
---|
| 1616 | break; |
---|
| 1617 | } |
---|
| 1618 | } |
---|
| 1619 | } |
---|
| 1620 | result = 0; |
---|
| 1621 | break; |
---|
| 1622 | case STR_IS_LOWER: |
---|
| 1623 | chcomp = Tcl_UniCharIsLower; |
---|
| 1624 | break; |
---|
| 1625 | case STR_IS_PRINT: |
---|
| 1626 | chcomp = Tcl_UniCharIsPrint; |
---|
| 1627 | break; |
---|
| 1628 | case STR_IS_PUNCT: |
---|
| 1629 | chcomp = Tcl_UniCharIsPunct; |
---|
| 1630 | break; |
---|
| 1631 | case STR_IS_SPACE: |
---|
| 1632 | chcomp = Tcl_UniCharIsSpace; |
---|
| 1633 | break; |
---|
| 1634 | case STR_IS_UPPER: |
---|
| 1635 | chcomp = Tcl_UniCharIsUpper; |
---|
| 1636 | break; |
---|
| 1637 | case STR_IS_WORD: |
---|
| 1638 | chcomp = Tcl_UniCharIsWordChar; |
---|
| 1639 | break; |
---|
| 1640 | case STR_IS_XDIGIT: |
---|
| 1641 | for (; string1 < end; string1++, failat++) { |
---|
| 1642 | /* INTL: We assume unicode is bad for this class. */ |
---|
| 1643 | if ((*((unsigned char *)string1) >= 0xC0) || |
---|
| 1644 | !isxdigit(*(unsigned char *)string1)) { |
---|
| 1645 | result = 0; |
---|
| 1646 | break; |
---|
| 1647 | } |
---|
| 1648 | } |
---|
| 1649 | break; |
---|
| 1650 | } |
---|
| 1651 | if (chcomp != NULL) { |
---|
| 1652 | for (; string1 < end; string1 += length2, failat++) { |
---|
| 1653 | length2 = TclUtfToUniChar(string1, &ch); |
---|
| 1654 | if (!chcomp(ch)) { |
---|
| 1655 | result = 0; |
---|
| 1656 | break; |
---|
| 1657 | } |
---|
| 1658 | } |
---|
| 1659 | } |
---|
| 1660 | |
---|
| 1661 | /* |
---|
| 1662 | * Only set the failVarObj when we will return 0 and we have indicated a |
---|
| 1663 | * valid fail index (>= 0). |
---|
| 1664 | */ |
---|
| 1665 | |
---|
| 1666 | str_is_done: |
---|
| 1667 | if ((result == 0) && (failVarObj != NULL) && |
---|
| 1668 | Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), |
---|
| 1669 | TCL_LEAVE_ERR_MSG) == NULL) { |
---|
| 1670 | return TCL_ERROR; |
---|
| 1671 | } |
---|
| 1672 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); |
---|
| 1673 | return TCL_OK; |
---|
| 1674 | } |
---|
| 1675 | |
---|
| 1676 | static int |
---|
| 1677 | UniCharIsAscii( |
---|
| 1678 | int character) |
---|
| 1679 | { |
---|
| 1680 | return (character >= 0) && (character < 0x80); |
---|
| 1681 | } |
---|
| 1682 | |
---|
| 1683 | /* |
---|
| 1684 | *---------------------------------------------------------------------- |
---|
| 1685 | * |
---|
| 1686 | * StringMapCmd -- |
---|
| 1687 | * |
---|
| 1688 | * This procedure is invoked to process the "string map" Tcl command. See |
---|
| 1689 | * the user documentation for details on what it does. Note that this |
---|
| 1690 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 1691 | * |
---|
| 1692 | * Results: |
---|
| 1693 | * A standard Tcl result. |
---|
| 1694 | * |
---|
| 1695 | * Side effects: |
---|
| 1696 | * See the user documentation. |
---|
| 1697 | * |
---|
| 1698 | *---------------------------------------------------------------------- |
---|
| 1699 | */ |
---|
| 1700 | |
---|
| 1701 | static int |
---|
| 1702 | StringMapCmd( |
---|
| 1703 | ClientData dummy, /* Not used. */ |
---|
| 1704 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 1705 | int objc, /* Number of arguments. */ |
---|
| 1706 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 1707 | { |
---|
| 1708 | int length1, length2, mapElemc, index; |
---|
| 1709 | int nocase = 0, mapWithDict = 0, copySource = 0; |
---|
| 1710 | Tcl_Obj **mapElemv, *sourceObj, *resultPtr; |
---|
| 1711 | Tcl_UniChar *ustring1, *ustring2, *p, *end; |
---|
| 1712 | int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, unsigned long); |
---|
| 1713 | |
---|
| 1714 | if (objc < 3 || objc > 4) { |
---|
| 1715 | Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string"); |
---|
| 1716 | return TCL_ERROR; |
---|
| 1717 | } |
---|
| 1718 | |
---|
| 1719 | if (objc == 4) { |
---|
| 1720 | const char *string = TclGetStringFromObj(objv[1], &length2); |
---|
| 1721 | |
---|
| 1722 | if ((length2 > 1) && |
---|
| 1723 | strncmp(string, "-nocase", (size_t) length2) == 0) { |
---|
| 1724 | nocase = 1; |
---|
| 1725 | } else { |
---|
| 1726 | Tcl_AppendResult(interp, "bad option \"", string, |
---|
| 1727 | "\": must be -nocase", NULL); |
---|
| 1728 | return TCL_ERROR; |
---|
| 1729 | } |
---|
| 1730 | } |
---|
| 1731 | |
---|
| 1732 | /* |
---|
| 1733 | * This test is tricky, but has to be that way or you get other strange |
---|
| 1734 | * inconsistencies (see test string-10.20 for illustration why!) |
---|
| 1735 | */ |
---|
| 1736 | |
---|
| 1737 | if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ |
---|
| 1738 | int i, done; |
---|
| 1739 | Tcl_DictSearch search; |
---|
| 1740 | |
---|
| 1741 | /* |
---|
| 1742 | * We know the type exactly, so all dict operations will succeed for |
---|
| 1743 | * sure. This shortens this code quite a bit. |
---|
| 1744 | */ |
---|
| 1745 | |
---|
| 1746 | Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); |
---|
| 1747 | if (mapElemc == 0) { |
---|
| 1748 | /* |
---|
| 1749 | * Empty charMap, just return whatever string was given. |
---|
| 1750 | */ |
---|
| 1751 | |
---|
| 1752 | Tcl_SetObjResult(interp, objv[objc-1]); |
---|
| 1753 | return TCL_OK; |
---|
| 1754 | } |
---|
| 1755 | |
---|
| 1756 | mapElemc *= 2; |
---|
| 1757 | mapWithDict = 1; |
---|
| 1758 | |
---|
| 1759 | /* |
---|
| 1760 | * Copy the dictionary out into an array; that's the easiest way to |
---|
| 1761 | * adapt this code... |
---|
| 1762 | */ |
---|
| 1763 | |
---|
| 1764 | mapElemv = (Tcl_Obj **) |
---|
| 1765 | TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); |
---|
| 1766 | Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, |
---|
| 1767 | mapElemv+1, &done); |
---|
| 1768 | for (i=2 ; i<mapElemc ; i+=2) { |
---|
| 1769 | Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done); |
---|
| 1770 | } |
---|
| 1771 | Tcl_DictObjDone(&search); |
---|
| 1772 | } else { |
---|
| 1773 | if (TclListObjGetElements(interp, objv[objc-2], &mapElemc, |
---|
| 1774 | &mapElemv) != TCL_OK) { |
---|
| 1775 | return TCL_ERROR; |
---|
| 1776 | } |
---|
| 1777 | if (mapElemc == 0) { |
---|
| 1778 | /* |
---|
| 1779 | * empty charMap, just return whatever string was given. |
---|
| 1780 | */ |
---|
| 1781 | |
---|
| 1782 | Tcl_SetObjResult(interp, objv[objc-1]); |
---|
| 1783 | return TCL_OK; |
---|
| 1784 | } else if (mapElemc & 1) { |
---|
| 1785 | /* |
---|
| 1786 | * The charMap must be an even number of key/value items. |
---|
| 1787 | */ |
---|
| 1788 | |
---|
| 1789 | Tcl_SetObjResult(interp, |
---|
| 1790 | Tcl_NewStringObj("char map list unbalanced", -1)); |
---|
| 1791 | return TCL_ERROR; |
---|
| 1792 | } |
---|
| 1793 | } |
---|
| 1794 | |
---|
| 1795 | /* |
---|
| 1796 | * Take a copy of the source string object if it is the same as the map |
---|
| 1797 | * string to cut out nasty sharing crashes. [Bug 1018562] |
---|
| 1798 | */ |
---|
| 1799 | |
---|
| 1800 | if (objv[objc-2] == objv[objc-1]) { |
---|
| 1801 | sourceObj = Tcl_DuplicateObj(objv[objc-1]); |
---|
| 1802 | copySource = 1; |
---|
| 1803 | } else { |
---|
| 1804 | sourceObj = objv[objc-1]; |
---|
| 1805 | } |
---|
| 1806 | ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); |
---|
| 1807 | if (length1 == 0) { |
---|
| 1808 | /* |
---|
| 1809 | * Empty input string, just stop now. |
---|
| 1810 | */ |
---|
| 1811 | |
---|
| 1812 | goto done; |
---|
| 1813 | } |
---|
| 1814 | end = ustring1 + length1; |
---|
| 1815 | |
---|
| 1816 | strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); |
---|
| 1817 | |
---|
| 1818 | /* |
---|
| 1819 | * Force result to be Unicode |
---|
| 1820 | */ |
---|
| 1821 | |
---|
| 1822 | resultPtr = Tcl_NewUnicodeObj(ustring1, 0); |
---|
| 1823 | |
---|
| 1824 | if (mapElemc == 2) { |
---|
| 1825 | /* |
---|
| 1826 | * Special case for one map pair which avoids the extra for loop and |
---|
| 1827 | * extra calls to get Unicode data. The algorithm is otherwise |
---|
| 1828 | * identical to the multi-pair case. This will be >30% faster on |
---|
| 1829 | * larger strings. |
---|
| 1830 | */ |
---|
| 1831 | |
---|
| 1832 | int mapLen; |
---|
| 1833 | Tcl_UniChar *mapString, u2lc; |
---|
| 1834 | |
---|
| 1835 | ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); |
---|
| 1836 | p = ustring1; |
---|
| 1837 | if ((length2 > length1) || (length2 == 0)) { |
---|
| 1838 | /* |
---|
| 1839 | * Match string is either longer than input or empty. |
---|
| 1840 | */ |
---|
| 1841 | |
---|
| 1842 | ustring1 = end; |
---|
| 1843 | } else { |
---|
| 1844 | mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); |
---|
| 1845 | u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); |
---|
| 1846 | for (; ustring1 < end; ustring1++) { |
---|
| 1847 | if (((*ustring1 == *ustring2) || |
---|
| 1848 | (nocase&&Tcl_UniCharToLower(*ustring1)==u2lc)) && |
---|
| 1849 | (length2==1 || strCmpFn(ustring1, ustring2, |
---|
| 1850 | (unsigned long) length2) == 0)) { |
---|
| 1851 | if (p != ustring1) { |
---|
| 1852 | Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); |
---|
| 1853 | p = ustring1 + length2; |
---|
| 1854 | } else { |
---|
| 1855 | p += length2; |
---|
| 1856 | } |
---|
| 1857 | ustring1 = p - 1; |
---|
| 1858 | |
---|
| 1859 | Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); |
---|
| 1860 | } |
---|
| 1861 | } |
---|
| 1862 | } |
---|
| 1863 | } else { |
---|
| 1864 | Tcl_UniChar **mapStrings, *u2lc = NULL; |
---|
| 1865 | int *mapLens; |
---|
| 1866 | |
---|
| 1867 | /* |
---|
| 1868 | * Precompute pointers to the unicode string and length. This saves us |
---|
| 1869 | * repeated function calls later, significantly speeding up the |
---|
| 1870 | * algorithm. We only need the lowercase first char in the nocase |
---|
| 1871 | * case. |
---|
| 1872 | */ |
---|
| 1873 | |
---|
| 1874 | mapStrings = (Tcl_UniChar **) TclStackAlloc(interp, |
---|
| 1875 | mapElemc * 2 * sizeof(Tcl_UniChar *)); |
---|
| 1876 | mapLens = (int *) TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); |
---|
| 1877 | if (nocase) { |
---|
| 1878 | u2lc = (Tcl_UniChar *) TclStackAlloc(interp, |
---|
| 1879 | mapElemc * sizeof(Tcl_UniChar)); |
---|
| 1880 | } |
---|
| 1881 | for (index = 0; index < mapElemc; index++) { |
---|
| 1882 | mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], |
---|
| 1883 | mapLens+index); |
---|
| 1884 | if (nocase && ((index % 2) == 0)) { |
---|
| 1885 | u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); |
---|
| 1886 | } |
---|
| 1887 | } |
---|
| 1888 | for (p = ustring1; ustring1 < end; ustring1++) { |
---|
| 1889 | for (index = 0; index < mapElemc; index += 2) { |
---|
| 1890 | /* |
---|
| 1891 | * Get the key string to match on. |
---|
| 1892 | */ |
---|
| 1893 | |
---|
| 1894 | ustring2 = mapStrings[index]; |
---|
| 1895 | length2 = mapLens[index]; |
---|
| 1896 | if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && |
---|
| 1897 | (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && |
---|
| 1898 | /* Restrict max compare length. */ |
---|
| 1899 | (end-ustring1 >= length2) && ((length2 == 1) || |
---|
| 1900 | !strCmpFn(ustring2, ustring1, (unsigned) length2))) { |
---|
| 1901 | if (p != ustring1) { |
---|
| 1902 | /* |
---|
| 1903 | * Put the skipped chars onto the result first. |
---|
| 1904 | */ |
---|
| 1905 | |
---|
| 1906 | Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); |
---|
| 1907 | p = ustring1 + length2; |
---|
| 1908 | } else { |
---|
| 1909 | p += length2; |
---|
| 1910 | } |
---|
| 1911 | |
---|
| 1912 | /* |
---|
| 1913 | * Adjust len to be full length of matched string. |
---|
| 1914 | */ |
---|
| 1915 | |
---|
| 1916 | ustring1 = p - 1; |
---|
| 1917 | |
---|
| 1918 | /* |
---|
| 1919 | * Append the map value to the unicode string. |
---|
| 1920 | */ |
---|
| 1921 | |
---|
| 1922 | Tcl_AppendUnicodeToObj(resultPtr, |
---|
| 1923 | mapStrings[index+1], mapLens[index+1]); |
---|
| 1924 | break; |
---|
| 1925 | } |
---|
| 1926 | } |
---|
| 1927 | } |
---|
| 1928 | if (nocase) { |
---|
| 1929 | TclStackFree(interp, u2lc); |
---|
| 1930 | } |
---|
| 1931 | TclStackFree(interp, mapLens); |
---|
| 1932 | TclStackFree(interp, mapStrings); |
---|
| 1933 | } |
---|
| 1934 | if (p != ustring1) { |
---|
| 1935 | /* |
---|
| 1936 | * Put the rest of the unmapped chars onto result. |
---|
| 1937 | */ |
---|
| 1938 | |
---|
| 1939 | Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); |
---|
| 1940 | } |
---|
| 1941 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 1942 | done: |
---|
| 1943 | if (mapWithDict) { |
---|
| 1944 | TclStackFree(interp, mapElemv); |
---|
| 1945 | } |
---|
| 1946 | if (copySource) { |
---|
| 1947 | Tcl_DecrRefCount(sourceObj); |
---|
| 1948 | } |
---|
| 1949 | return TCL_OK; |
---|
| 1950 | } |
---|
| 1951 | |
---|
| 1952 | /* |
---|
| 1953 | *---------------------------------------------------------------------- |
---|
| 1954 | * |
---|
| 1955 | * StringMatchCmd -- |
---|
| 1956 | * |
---|
| 1957 | * This procedure is invoked to process the "string match" Tcl command. |
---|
| 1958 | * See the user documentation for details on what it does. Note that this |
---|
| 1959 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 1960 | * |
---|
| 1961 | * Results: |
---|
| 1962 | * A standard Tcl result. |
---|
| 1963 | * |
---|
| 1964 | * Side effects: |
---|
| 1965 | * See the user documentation. |
---|
| 1966 | * |
---|
| 1967 | *---------------------------------------------------------------------- |
---|
| 1968 | */ |
---|
| 1969 | |
---|
| 1970 | static int |
---|
| 1971 | StringMatchCmd( |
---|
| 1972 | ClientData dummy, /* Not used. */ |
---|
| 1973 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 1974 | int objc, /* Number of arguments. */ |
---|
| 1975 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 1976 | { |
---|
| 1977 | int nocase = 0; |
---|
| 1978 | |
---|
| 1979 | if (objc < 3 || objc > 4) { |
---|
| 1980 | Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string"); |
---|
| 1981 | return TCL_ERROR; |
---|
| 1982 | } |
---|
| 1983 | |
---|
| 1984 | if (objc == 4) { |
---|
| 1985 | int length; |
---|
| 1986 | const char *string = TclGetStringFromObj(objv[1], &length); |
---|
| 1987 | |
---|
| 1988 | if ((length > 1) && |
---|
| 1989 | strncmp(string, "-nocase", (size_t) length) == 0) { |
---|
| 1990 | nocase = TCL_MATCH_NOCASE; |
---|
| 1991 | } else { |
---|
| 1992 | Tcl_AppendResult(interp, "bad option \"", string, |
---|
| 1993 | "\": must be -nocase", NULL); |
---|
| 1994 | return TCL_ERROR; |
---|
| 1995 | } |
---|
| 1996 | } |
---|
| 1997 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj( |
---|
| 1998 | TclStringMatchObj(objv[objc-1], objv[objc-2], nocase))); |
---|
| 1999 | return TCL_OK; |
---|
| 2000 | } |
---|
| 2001 | |
---|
| 2002 | /* |
---|
| 2003 | *---------------------------------------------------------------------- |
---|
| 2004 | * |
---|
| 2005 | * StringRangeCmd -- |
---|
| 2006 | * |
---|
| 2007 | * This procedure is invoked to process the "string range" Tcl command. |
---|
| 2008 | * See the user documentation for details on what it does. Note that this |
---|
| 2009 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 2010 | * |
---|
| 2011 | * Results: |
---|
| 2012 | * A standard Tcl result. |
---|
| 2013 | * |
---|
| 2014 | * Side effects: |
---|
| 2015 | * See the user documentation. |
---|
| 2016 | * |
---|
| 2017 | *---------------------------------------------------------------------- |
---|
| 2018 | */ |
---|
| 2019 | |
---|
| 2020 | static int |
---|
| 2021 | StringRangeCmd( |
---|
| 2022 | ClientData dummy, /* Not used. */ |
---|
| 2023 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2024 | int objc, /* Number of arguments. */ |
---|
| 2025 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2026 | { |
---|
| 2027 | const unsigned char *string; |
---|
| 2028 | int length, first, last; |
---|
| 2029 | |
---|
| 2030 | if (objc != 4) { |
---|
| 2031 | Tcl_WrongNumArgs(interp, 1, objv, "string first last"); |
---|
| 2032 | return TCL_ERROR; |
---|
| 2033 | } |
---|
| 2034 | |
---|
| 2035 | /* |
---|
| 2036 | * If we have a ByteArray object, avoid indexing in the Utf string since |
---|
| 2037 | * the byte array contains one byte per character. Otherwise, use the |
---|
| 2038 | * Unicode string rep to get the range. |
---|
| 2039 | */ |
---|
| 2040 | |
---|
| 2041 | if (objv[1]->typePtr == &tclByteArrayType) { |
---|
| 2042 | string = Tcl_GetByteArrayFromObj(objv[1], &length); |
---|
| 2043 | length--; |
---|
| 2044 | } else { |
---|
| 2045 | /* |
---|
| 2046 | * Get the length in actual characters. |
---|
| 2047 | */ |
---|
| 2048 | |
---|
| 2049 | string = NULL; |
---|
| 2050 | length = Tcl_GetCharLength(objv[1]) - 1; |
---|
| 2051 | } |
---|
| 2052 | |
---|
| 2053 | if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || |
---|
| 2054 | TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) { |
---|
| 2055 | return TCL_ERROR; |
---|
| 2056 | } |
---|
| 2057 | |
---|
| 2058 | if (first < 0) { |
---|
| 2059 | first = 0; |
---|
| 2060 | } |
---|
| 2061 | if (last >= length) { |
---|
| 2062 | last = length; |
---|
| 2063 | } |
---|
| 2064 | if (last >= first) { |
---|
| 2065 | if (string != NULL) { |
---|
| 2066 | /* |
---|
| 2067 | * Reread the string to prevent shimmering nasties. |
---|
| 2068 | */ |
---|
| 2069 | |
---|
| 2070 | string = Tcl_GetByteArrayFromObj(objv[1], &length); |
---|
| 2071 | Tcl_SetObjResult(interp, |
---|
| 2072 | Tcl_NewByteArrayObj(string+first, last - first + 1)); |
---|
| 2073 | } else { |
---|
| 2074 | Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); |
---|
| 2075 | } |
---|
| 2076 | } |
---|
| 2077 | return TCL_OK; |
---|
| 2078 | } |
---|
| 2079 | |
---|
| 2080 | /* |
---|
| 2081 | *---------------------------------------------------------------------- |
---|
| 2082 | * |
---|
| 2083 | * StringReptCmd -- |
---|
| 2084 | * |
---|
| 2085 | * This procedure is invoked to process the "string repeat" Tcl command. |
---|
| 2086 | * See the user documentation for details on what it does. Note that this |
---|
| 2087 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 2088 | * |
---|
| 2089 | * Results: |
---|
| 2090 | * A standard Tcl result. |
---|
| 2091 | * |
---|
| 2092 | * Side effects: |
---|
| 2093 | * See the user documentation. |
---|
| 2094 | * |
---|
| 2095 | *---------------------------------------------------------------------- |
---|
| 2096 | */ |
---|
| 2097 | |
---|
| 2098 | static int |
---|
| 2099 | StringReptCmd( |
---|
| 2100 | ClientData dummy, /* Not used. */ |
---|
| 2101 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2102 | int objc, /* Number of arguments. */ |
---|
| 2103 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2104 | { |
---|
| 2105 | const char *string1; |
---|
| 2106 | char *string2; |
---|
| 2107 | int count, index, length1, length2; |
---|
| 2108 | Tcl_Obj *resultPtr; |
---|
| 2109 | |
---|
| 2110 | if (objc != 3) { |
---|
| 2111 | Tcl_WrongNumArgs(interp, 1, objv, "string count"); |
---|
| 2112 | return TCL_ERROR; |
---|
| 2113 | } |
---|
| 2114 | |
---|
| 2115 | if (TclGetIntFromObj(interp, objv[2], &count) != TCL_OK) { |
---|
| 2116 | return TCL_ERROR; |
---|
| 2117 | } |
---|
| 2118 | |
---|
| 2119 | /* |
---|
| 2120 | * Check for cases that allow us to skip copying stuff. |
---|
| 2121 | */ |
---|
| 2122 | |
---|
| 2123 | if (count == 1) { |
---|
| 2124 | Tcl_SetObjResult(interp, objv[1]); |
---|
| 2125 | goto done; |
---|
| 2126 | } else if (count < 1) { |
---|
| 2127 | goto done; |
---|
| 2128 | } |
---|
| 2129 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
| 2130 | if (length1 <= 0) { |
---|
| 2131 | goto done; |
---|
| 2132 | } |
---|
| 2133 | |
---|
| 2134 | /* |
---|
| 2135 | * Only build up a string that has data. Instead of building it up with |
---|
| 2136 | * repeated appends, we just allocate the necessary space once and copy |
---|
| 2137 | * the string value in. Check for overflow with back-division. [Bug |
---|
| 2138 | * #714106] |
---|
| 2139 | */ |
---|
| 2140 | |
---|
| 2141 | length2 = length1 * count + 1; |
---|
| 2142 | if ((length2-1) / count != length1) { |
---|
| 2143 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( |
---|
| 2144 | "string size overflow, must be less than %d", INT_MAX)); |
---|
| 2145 | return TCL_ERROR; |
---|
| 2146 | } |
---|
| 2147 | |
---|
| 2148 | /* |
---|
| 2149 | * Include space for the NUL. |
---|
| 2150 | */ |
---|
| 2151 | |
---|
| 2152 | string2 = attemptckalloc((size_t) length2); |
---|
| 2153 | if (string2 == NULL) { |
---|
| 2154 | /* |
---|
| 2155 | * Alloc failed. Note that in this case we try to do an error message |
---|
| 2156 | * since this is a case that's most likely when the alloc is large and |
---|
| 2157 | * that's easy to do with this API. Note that if we fail allocating a |
---|
| 2158 | * short string, this will likely keel over too (and fatally). |
---|
| 2159 | */ |
---|
| 2160 | |
---|
| 2161 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( |
---|
| 2162 | "string size overflow, out of memory allocating %d bytes", |
---|
| 2163 | length2)); |
---|
| 2164 | return TCL_ERROR; |
---|
| 2165 | } |
---|
| 2166 | for (index = 0; index < count; index++) { |
---|
| 2167 | memcpy(string2 + (length1 * index), string1, (size_t) length1); |
---|
| 2168 | } |
---|
| 2169 | string2[length2-1] = '\0'; |
---|
| 2170 | |
---|
| 2171 | /* |
---|
| 2172 | * We have to directly assign this instead of using Tcl_SetStringObj (and |
---|
| 2173 | * indirectly TclInitStringRep) because that makes another copy of the |
---|
| 2174 | * data. |
---|
| 2175 | */ |
---|
| 2176 | |
---|
| 2177 | TclNewObj(resultPtr); |
---|
| 2178 | resultPtr->bytes = string2; |
---|
| 2179 | resultPtr->length = length2-1; |
---|
| 2180 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 2181 | |
---|
| 2182 | done: |
---|
| 2183 | return TCL_OK; |
---|
| 2184 | } |
---|
| 2185 | |
---|
| 2186 | /* |
---|
| 2187 | *---------------------------------------------------------------------- |
---|
| 2188 | * |
---|
| 2189 | * StringRplcCmd -- |
---|
| 2190 | * |
---|
| 2191 | * This procedure is invoked to process the "string replace" Tcl command. |
---|
| 2192 | * See the user documentation for details on what it does. Note that this |
---|
| 2193 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 2194 | * |
---|
| 2195 | * Results: |
---|
| 2196 | * A standard Tcl result. |
---|
| 2197 | * |
---|
| 2198 | * Side effects: |
---|
| 2199 | * See the user documentation. |
---|
| 2200 | * |
---|
| 2201 | *---------------------------------------------------------------------- |
---|
| 2202 | */ |
---|
| 2203 | |
---|
| 2204 | static int |
---|
| 2205 | StringRplcCmd( |
---|
| 2206 | ClientData dummy, /* Not used. */ |
---|
| 2207 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2208 | int objc, /* Number of arguments. */ |
---|
| 2209 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2210 | { |
---|
| 2211 | Tcl_UniChar *ustring; |
---|
| 2212 | int first, last, length; |
---|
| 2213 | |
---|
| 2214 | if (objc < 4 || objc > 5) { |
---|
| 2215 | Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); |
---|
| 2216 | return TCL_ERROR; |
---|
| 2217 | } |
---|
| 2218 | |
---|
| 2219 | ustring = Tcl_GetUnicodeFromObj(objv[1], &length); |
---|
| 2220 | length--; |
---|
| 2221 | |
---|
| 2222 | if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || |
---|
| 2223 | TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ |
---|
| 2224 | return TCL_ERROR; |
---|
| 2225 | } |
---|
| 2226 | |
---|
| 2227 | if ((last < first) || (last < 0) || (first > length)) { |
---|
| 2228 | Tcl_SetObjResult(interp, objv[1]); |
---|
| 2229 | } else { |
---|
| 2230 | Tcl_Obj *resultPtr; |
---|
| 2231 | |
---|
| 2232 | ustring = Tcl_GetUnicodeFromObj(objv[1], &length); |
---|
| 2233 | length--; |
---|
| 2234 | |
---|
| 2235 | if (first < 0) { |
---|
| 2236 | first = 0; |
---|
| 2237 | } |
---|
| 2238 | |
---|
| 2239 | resultPtr = Tcl_NewUnicodeObj(ustring, first); |
---|
| 2240 | if (objc == 5) { |
---|
| 2241 | Tcl_AppendObjToObj(resultPtr, objv[4]); |
---|
| 2242 | } |
---|
| 2243 | if (last < length) { |
---|
| 2244 | Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, |
---|
| 2245 | length - last); |
---|
| 2246 | } |
---|
| 2247 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 2248 | } |
---|
| 2249 | return TCL_OK; |
---|
| 2250 | } |
---|
| 2251 | |
---|
| 2252 | /* |
---|
| 2253 | *---------------------------------------------------------------------- |
---|
| 2254 | * |
---|
| 2255 | * StringRevCmd -- |
---|
| 2256 | * |
---|
| 2257 | * This procedure is invoked to process the "string reverse" Tcl command. |
---|
| 2258 | * See the user documentation for details on what it does. Note that this |
---|
| 2259 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 2260 | * |
---|
| 2261 | * Results: |
---|
| 2262 | * A standard Tcl result. |
---|
| 2263 | * |
---|
| 2264 | * Side effects: |
---|
| 2265 | * See the user documentation. |
---|
| 2266 | * |
---|
| 2267 | *---------------------------------------------------------------------- |
---|
| 2268 | */ |
---|
| 2269 | |
---|
| 2270 | static int |
---|
| 2271 | StringRevCmd( |
---|
| 2272 | ClientData dummy, /* Not used. */ |
---|
| 2273 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2274 | int objc, /* Number of arguments. */ |
---|
| 2275 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2276 | { |
---|
| 2277 | if (objc != 2) { |
---|
| 2278 | Tcl_WrongNumArgs(interp, 1, objv, "string"); |
---|
| 2279 | return TCL_ERROR; |
---|
| 2280 | } |
---|
| 2281 | |
---|
| 2282 | Tcl_SetObjResult(interp, TclStringObjReverse(objv[1])); |
---|
| 2283 | return TCL_OK; |
---|
| 2284 | } |
---|
| 2285 | |
---|
| 2286 | /* |
---|
| 2287 | *---------------------------------------------------------------------- |
---|
| 2288 | * |
---|
| 2289 | * StringStartCmd -- |
---|
| 2290 | * |
---|
| 2291 | * This procedure is invoked to process the "string wordstart" Tcl |
---|
| 2292 | * command. See the user documentation for details on what it does. Note |
---|
| 2293 | * that this command only functions correctly on properly formed Tcl UTF |
---|
| 2294 | * strings. |
---|
| 2295 | * |
---|
| 2296 | * Results: |
---|
| 2297 | * A standard Tcl result. |
---|
| 2298 | * |
---|
| 2299 | * Side effects: |
---|
| 2300 | * See the user documentation. |
---|
| 2301 | * |
---|
| 2302 | *---------------------------------------------------------------------- |
---|
| 2303 | */ |
---|
| 2304 | |
---|
| 2305 | static int |
---|
| 2306 | StringStartCmd( |
---|
| 2307 | ClientData dummy, /* Not used. */ |
---|
| 2308 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2309 | int objc, /* Number of arguments. */ |
---|
| 2310 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2311 | { |
---|
| 2312 | Tcl_UniChar ch; |
---|
| 2313 | const char *p, *string; |
---|
| 2314 | int cur, index, length, numChars; |
---|
| 2315 | |
---|
| 2316 | if (objc != 3) { |
---|
| 2317 | Tcl_WrongNumArgs(interp, 1, objv, "string index"); |
---|
| 2318 | return TCL_ERROR; |
---|
| 2319 | } |
---|
| 2320 | |
---|
| 2321 | string = TclGetStringFromObj(objv[1], &length); |
---|
| 2322 | numChars = Tcl_NumUtfChars(string, length); |
---|
| 2323 | if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { |
---|
| 2324 | return TCL_ERROR; |
---|
| 2325 | } |
---|
| 2326 | string = TclGetStringFromObj(objv[1], &length); |
---|
| 2327 | if (index >= numChars) { |
---|
| 2328 | index = numChars - 1; |
---|
| 2329 | } |
---|
| 2330 | cur = 0; |
---|
| 2331 | if (index > 0) { |
---|
| 2332 | p = Tcl_UtfAtIndex(string, index); |
---|
| 2333 | for (cur = index; cur >= 0; cur--) { |
---|
| 2334 | TclUtfToUniChar(p, &ch); |
---|
| 2335 | if (!Tcl_UniCharIsWordChar(ch)) { |
---|
| 2336 | break; |
---|
| 2337 | } |
---|
| 2338 | p = Tcl_UtfPrev(p, string); |
---|
| 2339 | } |
---|
| 2340 | if (cur != index) { |
---|
| 2341 | cur += 1; |
---|
| 2342 | } |
---|
| 2343 | } |
---|
| 2344 | Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); |
---|
| 2345 | return TCL_OK; |
---|
| 2346 | } |
---|
| 2347 | |
---|
| 2348 | /* |
---|
| 2349 | *---------------------------------------------------------------------- |
---|
| 2350 | * |
---|
| 2351 | * StringEndCmd -- |
---|
| 2352 | * |
---|
| 2353 | * This procedure is invoked to process the "string wordend" Tcl command. |
---|
| 2354 | * See the user documentation for details on what it does. Note that this |
---|
| 2355 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 2356 | * |
---|
| 2357 | * Results: |
---|
| 2358 | * A standard Tcl result. |
---|
| 2359 | * |
---|
| 2360 | * Side effects: |
---|
| 2361 | * See the user documentation. |
---|
| 2362 | * |
---|
| 2363 | *---------------------------------------------------------------------- |
---|
| 2364 | */ |
---|
| 2365 | |
---|
| 2366 | static int |
---|
| 2367 | StringEndCmd( |
---|
| 2368 | ClientData dummy, /* Not used. */ |
---|
| 2369 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2370 | int objc, /* Number of arguments. */ |
---|
| 2371 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2372 | { |
---|
| 2373 | Tcl_UniChar ch; |
---|
| 2374 | const char *p, *end, *string; |
---|
| 2375 | int cur, index, length, numChars; |
---|
| 2376 | |
---|
| 2377 | if (objc != 3) { |
---|
| 2378 | Tcl_WrongNumArgs(interp, 1, objv, "string index"); |
---|
| 2379 | return TCL_ERROR; |
---|
| 2380 | } |
---|
| 2381 | |
---|
| 2382 | string = TclGetStringFromObj(objv[1], &length); |
---|
| 2383 | numChars = Tcl_NumUtfChars(string, length); |
---|
| 2384 | if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { |
---|
| 2385 | return TCL_ERROR; |
---|
| 2386 | } |
---|
| 2387 | string = TclGetStringFromObj(objv[1], &length); |
---|
| 2388 | if (index < 0) { |
---|
| 2389 | index = 0; |
---|
| 2390 | } |
---|
| 2391 | if (index < numChars) { |
---|
| 2392 | p = Tcl_UtfAtIndex(string, index); |
---|
| 2393 | end = string+length; |
---|
| 2394 | for (cur = index; p < end; cur++) { |
---|
| 2395 | p += TclUtfToUniChar(p, &ch); |
---|
| 2396 | if (!Tcl_UniCharIsWordChar(ch)) { |
---|
| 2397 | break; |
---|
| 2398 | } |
---|
| 2399 | } |
---|
| 2400 | if (cur == index) { |
---|
| 2401 | cur++; |
---|
| 2402 | } |
---|
| 2403 | } else { |
---|
| 2404 | cur = numChars; |
---|
| 2405 | } |
---|
| 2406 | Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); |
---|
| 2407 | return TCL_OK; |
---|
| 2408 | } |
---|
| 2409 | |
---|
| 2410 | /* |
---|
| 2411 | *---------------------------------------------------------------------- |
---|
| 2412 | * |
---|
| 2413 | * StringEqualCmd -- |
---|
| 2414 | * |
---|
| 2415 | * This procedure is invoked to process the "string equal" Tcl command. |
---|
| 2416 | * See the user documentation for details on what it does. Note that this |
---|
| 2417 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 2418 | * |
---|
| 2419 | * Results: |
---|
| 2420 | * A standard Tcl result. |
---|
| 2421 | * |
---|
| 2422 | * Side effects: |
---|
| 2423 | * See the user documentation. |
---|
| 2424 | * |
---|
| 2425 | *---------------------------------------------------------------------- |
---|
| 2426 | */ |
---|
| 2427 | |
---|
| 2428 | static int |
---|
| 2429 | StringEqualCmd( |
---|
| 2430 | ClientData dummy, /* Not used. */ |
---|
| 2431 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2432 | int objc, /* Number of arguments. */ |
---|
| 2433 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2434 | { |
---|
| 2435 | /* |
---|
| 2436 | * Remember to keep code here in some sync with the byte-compiled versions |
---|
| 2437 | * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as |
---|
| 2438 | * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). |
---|
| 2439 | */ |
---|
| 2440 | |
---|
| 2441 | char *string1, *string2; |
---|
| 2442 | int length1, length2, i, match, length, nocase = 0, reqlength = -1; |
---|
| 2443 | typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); |
---|
| 2444 | strCmpFn_t strCmpFn; |
---|
| 2445 | |
---|
| 2446 | if (objc < 3 || objc > 6) { |
---|
| 2447 | str_cmp_args: |
---|
| 2448 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 2449 | "?-nocase? ?-length int? string1 string2"); |
---|
| 2450 | return TCL_ERROR; |
---|
| 2451 | } |
---|
| 2452 | |
---|
| 2453 | for (i = 1; i < objc-2; i++) { |
---|
| 2454 | string2 = TclGetStringFromObj(objv[i], &length2); |
---|
| 2455 | if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { |
---|
| 2456 | nocase = 1; |
---|
| 2457 | } else if ((length2 > 1) |
---|
| 2458 | && !strncmp(string2, "-length", (size_t)length2)) { |
---|
| 2459 | if (i+1 >= objc-2) { |
---|
| 2460 | goto str_cmp_args; |
---|
| 2461 | } |
---|
| 2462 | ++i; |
---|
| 2463 | if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { |
---|
| 2464 | return TCL_ERROR; |
---|
| 2465 | } |
---|
| 2466 | } else { |
---|
| 2467 | Tcl_AppendResult(interp, "bad option \"", string2, |
---|
| 2468 | "\": must be -nocase or -length", NULL); |
---|
| 2469 | return TCL_ERROR; |
---|
| 2470 | } |
---|
| 2471 | } |
---|
| 2472 | |
---|
| 2473 | /* |
---|
| 2474 | * From now on, we only access the two objects at the end of the argument |
---|
| 2475 | * array. |
---|
| 2476 | */ |
---|
| 2477 | |
---|
| 2478 | objv += objc-2; |
---|
| 2479 | |
---|
| 2480 | if ((reqlength == 0) || (objv[0] == objv[1])) { |
---|
| 2481 | /* |
---|
| 2482 | * Always match at 0 chars of if it is the same obj. |
---|
| 2483 | */ |
---|
| 2484 | |
---|
| 2485 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); |
---|
| 2486 | return TCL_OK; |
---|
| 2487 | } |
---|
| 2488 | |
---|
| 2489 | if (!nocase && objv[0]->typePtr == &tclByteArrayType && |
---|
| 2490 | objv[1]->typePtr == &tclByteArrayType) { |
---|
| 2491 | /* |
---|
| 2492 | * Use binary versions of comparisons since that won't cause undue |
---|
| 2493 | * type conversions and it is much faster. Only do this if we're |
---|
| 2494 | * case-sensitive (which is all that really makes sense with byte |
---|
| 2495 | * arrays anyway, and we have no memcasecmp() for some reason... :^) |
---|
| 2496 | */ |
---|
| 2497 | |
---|
| 2498 | string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); |
---|
| 2499 | string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); |
---|
| 2500 | strCmpFn = (strCmpFn_t) memcmp; |
---|
| 2501 | } else if ((objv[0]->typePtr == &tclStringType) |
---|
| 2502 | && (objv[1]->typePtr == &tclStringType)) { |
---|
| 2503 | /* |
---|
| 2504 | * Do a unicode-specific comparison if both of the args are of String |
---|
| 2505 | * type. In benchmark testing this proved the most efficient check |
---|
| 2506 | * between the unicode and string comparison operations. |
---|
| 2507 | */ |
---|
| 2508 | |
---|
| 2509 | string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); |
---|
| 2510 | string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); |
---|
| 2511 | strCmpFn = (strCmpFn_t) |
---|
| 2512 | (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); |
---|
| 2513 | } else { |
---|
| 2514 | /* |
---|
| 2515 | * As a catch-all we will work with UTF-8. We cannot use memcmp() as |
---|
| 2516 | * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's |
---|
| 2517 | * utf rep). We can use the more efficient TclpUtfNcmp2 if we are |
---|
| 2518 | * case-sensitive and no specific length was requested. |
---|
| 2519 | */ |
---|
| 2520 | |
---|
| 2521 | string1 = (char *) TclGetStringFromObj(objv[0], &length1); |
---|
| 2522 | string2 = (char *) TclGetStringFromObj(objv[1], &length2); |
---|
| 2523 | if ((reqlength < 0) && !nocase) { |
---|
| 2524 | strCmpFn = (strCmpFn_t) TclpUtfNcmp2; |
---|
| 2525 | } else { |
---|
| 2526 | length1 = Tcl_NumUtfChars(string1, length1); |
---|
| 2527 | length2 = Tcl_NumUtfChars(string2, length2); |
---|
| 2528 | strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); |
---|
| 2529 | } |
---|
| 2530 | } |
---|
| 2531 | |
---|
| 2532 | if ((reqlength < 0) && (length1 != length2)) { |
---|
| 2533 | match = 1; /* This will be reversed below. */ |
---|
| 2534 | } else { |
---|
| 2535 | length = (length1 < length2) ? length1 : length2; |
---|
| 2536 | if (reqlength > 0 && reqlength < length) { |
---|
| 2537 | length = reqlength; |
---|
| 2538 | } else if (reqlength < 0) { |
---|
| 2539 | /* |
---|
| 2540 | * The requested length is negative, so we ignore it by setting it |
---|
| 2541 | * to length + 1 so we correct the match var. |
---|
| 2542 | */ |
---|
| 2543 | |
---|
| 2544 | reqlength = length + 1; |
---|
| 2545 | } |
---|
| 2546 | |
---|
| 2547 | match = strCmpFn(string1, string2, (unsigned) length); |
---|
| 2548 | if ((match == 0) && (reqlength > length)) { |
---|
| 2549 | match = length1 - length2; |
---|
| 2550 | } |
---|
| 2551 | } |
---|
| 2552 | |
---|
| 2553 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); |
---|
| 2554 | return TCL_OK; |
---|
| 2555 | } |
---|
| 2556 | |
---|
| 2557 | /* |
---|
| 2558 | *---------------------------------------------------------------------- |
---|
| 2559 | * |
---|
| 2560 | * StringCmpCmd -- |
---|
| 2561 | * |
---|
| 2562 | * This procedure is invoked to process the "string compare" Tcl command. |
---|
| 2563 | * See the user documentation for details on what it does. Note that this |
---|
| 2564 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 2565 | * |
---|
| 2566 | * Results: |
---|
| 2567 | * A standard Tcl result. |
---|
| 2568 | * |
---|
| 2569 | * Side effects: |
---|
| 2570 | * See the user documentation. |
---|
| 2571 | * |
---|
| 2572 | *---------------------------------------------------------------------- |
---|
| 2573 | */ |
---|
| 2574 | |
---|
| 2575 | static int |
---|
| 2576 | StringCmpCmd( |
---|
| 2577 | ClientData dummy, /* Not used. */ |
---|
| 2578 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2579 | int objc, /* Number of arguments. */ |
---|
| 2580 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2581 | { |
---|
| 2582 | /* |
---|
| 2583 | * Remember to keep code here in some sync with the byte-compiled versions |
---|
| 2584 | * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as |
---|
| 2585 | * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). |
---|
| 2586 | */ |
---|
| 2587 | |
---|
| 2588 | char *string1, *string2; |
---|
| 2589 | int length1, length2, i, match, length, nocase = 0, reqlength = -1; |
---|
| 2590 | typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); |
---|
| 2591 | strCmpFn_t strCmpFn; |
---|
| 2592 | |
---|
| 2593 | if (objc < 3 || objc > 6) { |
---|
| 2594 | str_cmp_args: |
---|
| 2595 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 2596 | "?-nocase? ?-length int? string1 string2"); |
---|
| 2597 | return TCL_ERROR; |
---|
| 2598 | } |
---|
| 2599 | |
---|
| 2600 | for (i = 1; i < objc-2; i++) { |
---|
| 2601 | string2 = TclGetStringFromObj(objv[i], &length2); |
---|
| 2602 | if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { |
---|
| 2603 | nocase = 1; |
---|
| 2604 | } else if ((length2 > 1) |
---|
| 2605 | && !strncmp(string2, "-length", (size_t)length2)) { |
---|
| 2606 | if (i+1 >= objc-2) { |
---|
| 2607 | goto str_cmp_args; |
---|
| 2608 | } |
---|
| 2609 | ++i; |
---|
| 2610 | if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { |
---|
| 2611 | return TCL_ERROR; |
---|
| 2612 | } |
---|
| 2613 | } else { |
---|
| 2614 | Tcl_AppendResult(interp, "bad option \"", string2, |
---|
| 2615 | "\": must be -nocase or -length", NULL); |
---|
| 2616 | return TCL_ERROR; |
---|
| 2617 | } |
---|
| 2618 | } |
---|
| 2619 | |
---|
| 2620 | /* |
---|
| 2621 | * From now on, we only access the two objects at the end of the argument |
---|
| 2622 | * array. |
---|
| 2623 | */ |
---|
| 2624 | |
---|
| 2625 | objv += objc-2; |
---|
| 2626 | |
---|
| 2627 | if ((reqlength == 0) || (objv[0] == objv[1])) { |
---|
| 2628 | /* |
---|
| 2629 | * Always match at 0 chars of if it is the same obj. |
---|
| 2630 | */ |
---|
| 2631 | |
---|
| 2632 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); |
---|
| 2633 | return TCL_OK; |
---|
| 2634 | } |
---|
| 2635 | |
---|
| 2636 | if (!nocase && objv[0]->typePtr == &tclByteArrayType && |
---|
| 2637 | objv[1]->typePtr == &tclByteArrayType) { |
---|
| 2638 | /* |
---|
| 2639 | * Use binary versions of comparisons since that won't cause undue |
---|
| 2640 | * type conversions and it is much faster. Only do this if we're |
---|
| 2641 | * case-sensitive (which is all that really makes sense with byte |
---|
| 2642 | * arrays anyway, and we have no memcasecmp() for some reason... :^) |
---|
| 2643 | */ |
---|
| 2644 | |
---|
| 2645 | string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); |
---|
| 2646 | string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); |
---|
| 2647 | strCmpFn = (strCmpFn_t) memcmp; |
---|
| 2648 | } else if ((objv[0]->typePtr == &tclStringType) |
---|
| 2649 | && (objv[1]->typePtr == &tclStringType)) { |
---|
| 2650 | /* |
---|
| 2651 | * Do a unicode-specific comparison if both of the args are of String |
---|
| 2652 | * type. In benchmark testing this proved the most efficient check |
---|
| 2653 | * between the unicode and string comparison operations. |
---|
| 2654 | */ |
---|
| 2655 | |
---|
| 2656 | string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); |
---|
| 2657 | string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); |
---|
| 2658 | strCmpFn = (strCmpFn_t) |
---|
| 2659 | (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); |
---|
| 2660 | } else { |
---|
| 2661 | /* |
---|
| 2662 | * As a catch-all we will work with UTF-8. We cannot use memcmp() as |
---|
| 2663 | * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's |
---|
| 2664 | * utf rep). We can use the more efficient TclpUtfNcmp2 if we are |
---|
| 2665 | * case-sensitive and no specific length was requested. |
---|
| 2666 | */ |
---|
| 2667 | |
---|
| 2668 | string1 = (char *) TclGetStringFromObj(objv[0], &length1); |
---|
| 2669 | string2 = (char *) TclGetStringFromObj(objv[1], &length2); |
---|
| 2670 | if ((reqlength < 0) && !nocase) { |
---|
| 2671 | strCmpFn = (strCmpFn_t) TclpUtfNcmp2; |
---|
| 2672 | } else { |
---|
| 2673 | length1 = Tcl_NumUtfChars(string1, length1); |
---|
| 2674 | length2 = Tcl_NumUtfChars(string2, length2); |
---|
| 2675 | strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); |
---|
| 2676 | } |
---|
| 2677 | } |
---|
| 2678 | |
---|
| 2679 | length = (length1 < length2) ? length1 : length2; |
---|
| 2680 | if (reqlength > 0 && reqlength < length) { |
---|
| 2681 | length = reqlength; |
---|
| 2682 | } else if (reqlength < 0) { |
---|
| 2683 | /* |
---|
| 2684 | * The requested length is negative, so we ignore it by setting it to |
---|
| 2685 | * length + 1 so we correct the match var. |
---|
| 2686 | */ |
---|
| 2687 | |
---|
| 2688 | reqlength = length + 1; |
---|
| 2689 | } |
---|
| 2690 | |
---|
| 2691 | match = strCmpFn(string1, string2, (unsigned) length); |
---|
| 2692 | if ((match == 0) && (reqlength > length)) { |
---|
| 2693 | match = length1 - length2; |
---|
| 2694 | } |
---|
| 2695 | |
---|
| 2696 | Tcl_SetObjResult(interp, |
---|
| 2697 | Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); |
---|
| 2698 | return TCL_OK; |
---|
| 2699 | } |
---|
| 2700 | |
---|
| 2701 | /* |
---|
| 2702 | *---------------------------------------------------------------------- |
---|
| 2703 | * |
---|
| 2704 | * StringBytesCmd -- |
---|
| 2705 | * |
---|
| 2706 | * This procedure is invoked to process the "string bytelength" Tcl |
---|
| 2707 | * command. See the user documentation for details on what it does. Note |
---|
| 2708 | * that this command only functions correctly on properly formed Tcl UTF |
---|
| 2709 | * strings. |
---|
| 2710 | * |
---|
| 2711 | * Results: |
---|
| 2712 | * A standard Tcl result. |
---|
| 2713 | * |
---|
| 2714 | * Side effects: |
---|
| 2715 | * See the user documentation. |
---|
| 2716 | * |
---|
| 2717 | *---------------------------------------------------------------------- |
---|
| 2718 | */ |
---|
| 2719 | |
---|
| 2720 | static int |
---|
| 2721 | StringBytesCmd( |
---|
| 2722 | ClientData dummy, /* Not used. */ |
---|
| 2723 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2724 | int objc, /* Number of arguments. */ |
---|
| 2725 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2726 | { |
---|
| 2727 | int length; |
---|
| 2728 | |
---|
| 2729 | if (objc != 2) { |
---|
| 2730 | Tcl_WrongNumArgs(interp, 1, objv, "string"); |
---|
| 2731 | return TCL_ERROR; |
---|
| 2732 | } |
---|
| 2733 | |
---|
| 2734 | (void) TclGetStringFromObj(objv[1], &length); |
---|
| 2735 | Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); |
---|
| 2736 | return TCL_OK; |
---|
| 2737 | } |
---|
| 2738 | |
---|
| 2739 | /* |
---|
| 2740 | *---------------------------------------------------------------------- |
---|
| 2741 | * |
---|
| 2742 | * StringLenCmd -- |
---|
| 2743 | * |
---|
| 2744 | * This procedure is invoked to process the "string length" Tcl command. |
---|
| 2745 | * See the user documentation for details on what it does. Note that this |
---|
| 2746 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 2747 | * |
---|
| 2748 | * Results: |
---|
| 2749 | * A standard Tcl result. |
---|
| 2750 | * |
---|
| 2751 | * Side effects: |
---|
| 2752 | * See the user documentation. |
---|
| 2753 | * |
---|
| 2754 | *---------------------------------------------------------------------- |
---|
| 2755 | */ |
---|
| 2756 | |
---|
| 2757 | static int |
---|
| 2758 | StringLenCmd( |
---|
| 2759 | ClientData dummy, /* Not used. */ |
---|
| 2760 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2761 | int objc, /* Number of arguments. */ |
---|
| 2762 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2763 | { |
---|
| 2764 | int length; |
---|
| 2765 | |
---|
| 2766 | if (objc != 2) { |
---|
| 2767 | Tcl_WrongNumArgs(interp, 1, objv, "string"); |
---|
| 2768 | return TCL_ERROR; |
---|
| 2769 | } |
---|
| 2770 | |
---|
| 2771 | /* |
---|
| 2772 | * If we have a ByteArray object, avoid recomputing the string since the |
---|
| 2773 | * byte array contains one byte per character. Otherwise, use the Unicode |
---|
| 2774 | * string rep to calculate the length. |
---|
| 2775 | */ |
---|
| 2776 | |
---|
| 2777 | if (objv[1]->typePtr == &tclByteArrayType) { |
---|
| 2778 | (void) Tcl_GetByteArrayFromObj(objv[1], &length); |
---|
| 2779 | } else { |
---|
| 2780 | length = Tcl_GetCharLength(objv[1]); |
---|
| 2781 | } |
---|
| 2782 | Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); |
---|
| 2783 | return TCL_OK; |
---|
| 2784 | } |
---|
| 2785 | |
---|
| 2786 | /* |
---|
| 2787 | *---------------------------------------------------------------------- |
---|
| 2788 | * |
---|
| 2789 | * StringLowerCmd -- |
---|
| 2790 | * |
---|
| 2791 | * This procedure is invoked to process the "string tolower" Tcl command. |
---|
| 2792 | * See the user documentation for details on what it does. Note that this |
---|
| 2793 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 2794 | * |
---|
| 2795 | * Results: |
---|
| 2796 | * A standard Tcl result. |
---|
| 2797 | * |
---|
| 2798 | * Side effects: |
---|
| 2799 | * See the user documentation. |
---|
| 2800 | * |
---|
| 2801 | *---------------------------------------------------------------------- |
---|
| 2802 | */ |
---|
| 2803 | |
---|
| 2804 | static int |
---|
| 2805 | StringLowerCmd( |
---|
| 2806 | ClientData dummy, /* Not used. */ |
---|
| 2807 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2808 | int objc, /* Number of arguments. */ |
---|
| 2809 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2810 | { |
---|
| 2811 | int length1, length2; |
---|
| 2812 | char *string1, *string2; |
---|
| 2813 | |
---|
| 2814 | if (objc < 2 || objc > 4) { |
---|
| 2815 | Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); |
---|
| 2816 | return TCL_ERROR; |
---|
| 2817 | } |
---|
| 2818 | |
---|
| 2819 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
| 2820 | |
---|
| 2821 | if (objc == 2) { |
---|
| 2822 | Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); |
---|
| 2823 | |
---|
| 2824 | length1 = Tcl_UtfToLower(TclGetString(resultPtr)); |
---|
| 2825 | Tcl_SetObjLength(resultPtr, length1); |
---|
| 2826 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 2827 | } else { |
---|
| 2828 | int first, last; |
---|
| 2829 | const char *start, *end; |
---|
| 2830 | Tcl_Obj *resultPtr; |
---|
| 2831 | |
---|
| 2832 | length1 = Tcl_NumUtfChars(string1, length1) - 1; |
---|
| 2833 | if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { |
---|
| 2834 | return TCL_ERROR; |
---|
| 2835 | } |
---|
| 2836 | if (first < 0) { |
---|
| 2837 | first = 0; |
---|
| 2838 | } |
---|
| 2839 | last = first; |
---|
| 2840 | |
---|
| 2841 | if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, |
---|
| 2842 | &last) != TCL_OK)) { |
---|
| 2843 | return TCL_ERROR; |
---|
| 2844 | } |
---|
| 2845 | |
---|
| 2846 | if (last >= length1) { |
---|
| 2847 | last = length1; |
---|
| 2848 | } |
---|
| 2849 | if (last < first) { |
---|
| 2850 | Tcl_SetObjResult(interp, objv[1]); |
---|
| 2851 | return TCL_OK; |
---|
| 2852 | } |
---|
| 2853 | |
---|
| 2854 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
| 2855 | start = Tcl_UtfAtIndex(string1, first); |
---|
| 2856 | end = Tcl_UtfAtIndex(start, last - first + 1); |
---|
| 2857 | resultPtr = Tcl_NewStringObj(string1, end - string1); |
---|
| 2858 | string2 = TclGetString(resultPtr) + (start - string1); |
---|
| 2859 | |
---|
| 2860 | length2 = Tcl_UtfToLower(string2); |
---|
| 2861 | Tcl_SetObjLength(resultPtr, length2 + (start - string1)); |
---|
| 2862 | |
---|
| 2863 | Tcl_AppendToObj(resultPtr, end, -1); |
---|
| 2864 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 2865 | } |
---|
| 2866 | |
---|
| 2867 | return TCL_OK; |
---|
| 2868 | } |
---|
| 2869 | |
---|
| 2870 | /* |
---|
| 2871 | *---------------------------------------------------------------------- |
---|
| 2872 | * |
---|
| 2873 | * StringUpperCmd -- |
---|
| 2874 | * |
---|
| 2875 | * This procedure is invoked to process the "string toupper" Tcl command. |
---|
| 2876 | * See the user documentation for details on what it does. Note that this |
---|
| 2877 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 2878 | * |
---|
| 2879 | * Results: |
---|
| 2880 | * A standard Tcl result. |
---|
| 2881 | * |
---|
| 2882 | * Side effects: |
---|
| 2883 | * See the user documentation. |
---|
| 2884 | * |
---|
| 2885 | *---------------------------------------------------------------------- |
---|
| 2886 | */ |
---|
| 2887 | |
---|
| 2888 | static int |
---|
| 2889 | StringUpperCmd( |
---|
| 2890 | ClientData dummy, /* Not used. */ |
---|
| 2891 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2892 | int objc, /* Number of arguments. */ |
---|
| 2893 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2894 | { |
---|
| 2895 | int length1, length2; |
---|
| 2896 | char *string1, *string2; |
---|
| 2897 | |
---|
| 2898 | if (objc < 2 || objc > 4) { |
---|
| 2899 | Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); |
---|
| 2900 | return TCL_ERROR; |
---|
| 2901 | } |
---|
| 2902 | |
---|
| 2903 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
| 2904 | |
---|
| 2905 | if (objc == 2) { |
---|
| 2906 | Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); |
---|
| 2907 | |
---|
| 2908 | length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); |
---|
| 2909 | Tcl_SetObjLength(resultPtr, length1); |
---|
| 2910 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 2911 | } else { |
---|
| 2912 | int first, last; |
---|
| 2913 | const char *start, *end; |
---|
| 2914 | Tcl_Obj *resultPtr; |
---|
| 2915 | |
---|
| 2916 | length1 = Tcl_NumUtfChars(string1, length1) - 1; |
---|
| 2917 | if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { |
---|
| 2918 | return TCL_ERROR; |
---|
| 2919 | } |
---|
| 2920 | if (first < 0) { |
---|
| 2921 | first = 0; |
---|
| 2922 | } |
---|
| 2923 | last = first; |
---|
| 2924 | |
---|
| 2925 | if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, |
---|
| 2926 | &last) != TCL_OK)) { |
---|
| 2927 | return TCL_ERROR; |
---|
| 2928 | } |
---|
| 2929 | |
---|
| 2930 | if (last >= length1) { |
---|
| 2931 | last = length1; |
---|
| 2932 | } |
---|
| 2933 | if (last < first) { |
---|
| 2934 | Tcl_SetObjResult(interp, objv[1]); |
---|
| 2935 | return TCL_OK; |
---|
| 2936 | } |
---|
| 2937 | |
---|
| 2938 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
| 2939 | start = Tcl_UtfAtIndex(string1, first); |
---|
| 2940 | end = Tcl_UtfAtIndex(start, last - first + 1); |
---|
| 2941 | resultPtr = Tcl_NewStringObj(string1, end - string1); |
---|
| 2942 | string2 = TclGetString(resultPtr) + (start - string1); |
---|
| 2943 | |
---|
| 2944 | length2 = Tcl_UtfToUpper(string2); |
---|
| 2945 | Tcl_SetObjLength(resultPtr, length2 + (start - string1)); |
---|
| 2946 | |
---|
| 2947 | Tcl_AppendToObj(resultPtr, end, -1); |
---|
| 2948 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 2949 | } |
---|
| 2950 | |
---|
| 2951 | return TCL_OK; |
---|
| 2952 | } |
---|
| 2953 | |
---|
| 2954 | /* |
---|
| 2955 | *---------------------------------------------------------------------- |
---|
| 2956 | * |
---|
| 2957 | * StringTitleCmd -- |
---|
| 2958 | * |
---|
| 2959 | * This procedure is invoked to process the "string totitle" Tcl command. |
---|
| 2960 | * See the user documentation for details on what it does. Note that this |
---|
| 2961 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 2962 | * |
---|
| 2963 | * Results: |
---|
| 2964 | * A standard Tcl result. |
---|
| 2965 | * |
---|
| 2966 | * Side effects: |
---|
| 2967 | * See the user documentation. |
---|
| 2968 | * |
---|
| 2969 | *---------------------------------------------------------------------- |
---|
| 2970 | */ |
---|
| 2971 | |
---|
| 2972 | static int |
---|
| 2973 | StringTitleCmd( |
---|
| 2974 | ClientData dummy, /* Not used. */ |
---|
| 2975 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 2976 | int objc, /* Number of arguments. */ |
---|
| 2977 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2978 | { |
---|
| 2979 | int length1, length2; |
---|
| 2980 | char *string1, *string2; |
---|
| 2981 | |
---|
| 2982 | if (objc < 2 || objc > 4) { |
---|
| 2983 | Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); |
---|
| 2984 | return TCL_ERROR; |
---|
| 2985 | } |
---|
| 2986 | |
---|
| 2987 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
| 2988 | |
---|
| 2989 | if (objc == 2) { |
---|
| 2990 | Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); |
---|
| 2991 | |
---|
| 2992 | length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); |
---|
| 2993 | Tcl_SetObjLength(resultPtr, length1); |
---|
| 2994 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 2995 | } else { |
---|
| 2996 | int first, last; |
---|
| 2997 | const char *start, *end; |
---|
| 2998 | Tcl_Obj *resultPtr; |
---|
| 2999 | |
---|
| 3000 | length1 = Tcl_NumUtfChars(string1, length1) - 1; |
---|
| 3001 | if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { |
---|
| 3002 | return TCL_ERROR; |
---|
| 3003 | } |
---|
| 3004 | if (first < 0) { |
---|
| 3005 | first = 0; |
---|
| 3006 | } |
---|
| 3007 | last = first; |
---|
| 3008 | |
---|
| 3009 | if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, |
---|
| 3010 | &last) != TCL_OK)) { |
---|
| 3011 | return TCL_ERROR; |
---|
| 3012 | } |
---|
| 3013 | |
---|
| 3014 | if (last >= length1) { |
---|
| 3015 | last = length1; |
---|
| 3016 | } |
---|
| 3017 | if (last < first) { |
---|
| 3018 | Tcl_SetObjResult(interp, objv[1]); |
---|
| 3019 | return TCL_OK; |
---|
| 3020 | } |
---|
| 3021 | |
---|
| 3022 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
| 3023 | start = Tcl_UtfAtIndex(string1, first); |
---|
| 3024 | end = Tcl_UtfAtIndex(start, last - first + 1); |
---|
| 3025 | resultPtr = Tcl_NewStringObj(string1, end - string1); |
---|
| 3026 | string2 = TclGetString(resultPtr) + (start - string1); |
---|
| 3027 | |
---|
| 3028 | length2 = Tcl_UtfToTitle(string2); |
---|
| 3029 | Tcl_SetObjLength(resultPtr, length2 + (start - string1)); |
---|
| 3030 | |
---|
| 3031 | Tcl_AppendToObj(resultPtr, end, -1); |
---|
| 3032 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 3033 | } |
---|
| 3034 | |
---|
| 3035 | return TCL_OK; |
---|
| 3036 | } |
---|
| 3037 | |
---|
| 3038 | /* |
---|
| 3039 | *---------------------------------------------------------------------- |
---|
| 3040 | * |
---|
| 3041 | * StringTrimCmd -- |
---|
| 3042 | * |
---|
| 3043 | * This procedure is invoked to process the "string trim" Tcl command. |
---|
| 3044 | * See the user documentation for details on what it does. Note that this |
---|
| 3045 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
| 3046 | * |
---|
| 3047 | * Results: |
---|
| 3048 | * A standard Tcl result. |
---|
| 3049 | * |
---|
| 3050 | * Side effects: |
---|
| 3051 | * See the user documentation. |
---|
| 3052 | * |
---|
| 3053 | *---------------------------------------------------------------------- |
---|
| 3054 | */ |
---|
| 3055 | |
---|
| 3056 | static int |
---|
| 3057 | StringTrimCmd( |
---|
| 3058 | ClientData dummy, /* Not used. */ |
---|
| 3059 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 3060 | int objc, /* Number of arguments. */ |
---|
| 3061 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 3062 | { |
---|
| 3063 | Tcl_UniChar ch, trim; |
---|
| 3064 | register const char *p, *end; |
---|
| 3065 | const char *check, *checkEnd, *string1, *string2; |
---|
| 3066 | int offset, length1, length2; |
---|
| 3067 | |
---|
| 3068 | if (objc == 3) { |
---|
| 3069 | string2 = TclGetStringFromObj(objv[2], &length2); |
---|
| 3070 | } else if (objc == 2) { |
---|
| 3071 | string2 = " \t\n\r"; |
---|
| 3072 | length2 = strlen(string2); |
---|
| 3073 | } else { |
---|
| 3074 | Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); |
---|
| 3075 | return TCL_ERROR; |
---|
| 3076 | } |
---|
| 3077 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
| 3078 | checkEnd = string2 + length2; |
---|
| 3079 | |
---|
| 3080 | /* |
---|
| 3081 | * The outer loop iterates over the string. The inner loop iterates over |
---|
| 3082 | * the trim characters. The loops terminate as soon as a non-trim |
---|
| 3083 | * character is discovered and string1 is left pointing at the first |
---|
| 3084 | * non-trim character. |
---|
| 3085 | */ |
---|
| 3086 | |
---|
| 3087 | end = string1 + length1; |
---|
| 3088 | for (p = string1; p < end; p += offset) { |
---|
| 3089 | offset = TclUtfToUniChar(p, &ch); |
---|
| 3090 | |
---|
| 3091 | for (check = string2; ; ) { |
---|
| 3092 | if (check >= checkEnd) { |
---|
| 3093 | p = end; |
---|
| 3094 | break; |
---|
| 3095 | } |
---|
| 3096 | check += TclUtfToUniChar(check, &trim); |
---|
| 3097 | if (ch == trim) { |
---|
| 3098 | length1 -= offset; |
---|
| 3099 | string1 += offset; |
---|
| 3100 | break; |
---|
| 3101 | } |
---|
| 3102 | } |
---|
| 3103 | } |
---|
| 3104 | |
---|
| 3105 | /* |
---|
| 3106 | * The outer loop iterates over the string. The inner loop iterates over |
---|
| 3107 | * the trim characters. The loops terminate as soon as a non-trim |
---|
| 3108 | * character is discovered and length1 marks the last non-trim character. |
---|
| 3109 | */ |
---|
| 3110 | |
---|
| 3111 | end = string1; |
---|
| 3112 | for (p = string1 + length1; p > end; ) { |
---|
| 3113 | p = Tcl_UtfPrev(p, string1); |
---|
| 3114 | offset = TclUtfToUniChar(p, &ch); |
---|
| 3115 | check = string2; |
---|
| 3116 | while (1) { |
---|
| 3117 | if (check >= checkEnd) { |
---|
| 3118 | p = end; |
---|
| 3119 | break; |
---|
| 3120 | } |
---|
| 3121 | check += TclUtfToUniChar(check, &trim); |
---|
| 3122 | if (ch == trim) { |
---|
| 3123 | length1 -= offset; |
---|
| 3124 | break; |
---|
| 3125 | } |
---|
| 3126 | } |
---|
| 3127 | } |
---|
| 3128 | |
---|
| 3129 | Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); |
---|
| 3130 | return TCL_OK; |
---|
| 3131 | } |
---|
| 3132 | |
---|
| 3133 | /* |
---|
| 3134 | *---------------------------------------------------------------------- |
---|
| 3135 | * |
---|
| 3136 | * StringTrimLCmd -- |
---|
| 3137 | * |
---|
| 3138 | * This procedure is invoked to process the "string trimleft" Tcl |
---|
| 3139 | * command. See the user documentation for details on what it does. Note |
---|
| 3140 | * that this command only functions correctly on properly formed Tcl UTF |
---|
| 3141 | * strings. |
---|
| 3142 | * |
---|
| 3143 | * Results: |
---|
| 3144 | * A standard Tcl result. |
---|
| 3145 | * |
---|
| 3146 | * Side effects: |
---|
| 3147 | * See the user documentation. |
---|
| 3148 | * |
---|
| 3149 | *---------------------------------------------------------------------- |
---|
| 3150 | */ |
---|
| 3151 | |
---|
| 3152 | static int |
---|
| 3153 | StringTrimLCmd( |
---|
| 3154 | ClientData dummy, /* Not used. */ |
---|
| 3155 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 3156 | int objc, /* Number of arguments. */ |
---|
| 3157 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 3158 | { |
---|
| 3159 | Tcl_UniChar ch, trim; |
---|
| 3160 | register const char *p, *end; |
---|
| 3161 | const char *check, *checkEnd, *string1, *string2; |
---|
| 3162 | int offset, length1, length2; |
---|
| 3163 | |
---|
| 3164 | if (objc == 3) { |
---|
| 3165 | string2 = TclGetStringFromObj(objv[2], &length2); |
---|
| 3166 | } else if (objc == 2) { |
---|
| 3167 | string2 = " \t\n\r"; |
---|
| 3168 | length2 = strlen(string2); |
---|
| 3169 | } else { |
---|
| 3170 | Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); |
---|
| 3171 | return TCL_ERROR; |
---|
| 3172 | } |
---|
| 3173 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
| 3174 | checkEnd = string2 + length2; |
---|
| 3175 | |
---|
| 3176 | /* |
---|
| 3177 | * The outer loop iterates over the string. The inner loop iterates over |
---|
| 3178 | * the trim characters. The loops terminate as soon as a non-trim |
---|
| 3179 | * character is discovered and string1 is left pointing at the first |
---|
| 3180 | * non-trim character. |
---|
| 3181 | */ |
---|
| 3182 | |
---|
| 3183 | end = string1 + length1; |
---|
| 3184 | for (p = string1; p < end; p += offset) { |
---|
| 3185 | offset = TclUtfToUniChar(p, &ch); |
---|
| 3186 | |
---|
| 3187 | for (check = string2; ; ) { |
---|
| 3188 | if (check >= checkEnd) { |
---|
| 3189 | p = end; |
---|
| 3190 | break; |
---|
| 3191 | } |
---|
| 3192 | check += TclUtfToUniChar(check, &trim); |
---|
| 3193 | if (ch == trim) { |
---|
| 3194 | length1 -= offset; |
---|
| 3195 | string1 += offset; |
---|
| 3196 | break; |
---|
| 3197 | } |
---|
| 3198 | } |
---|
| 3199 | } |
---|
| 3200 | |
---|
| 3201 | Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); |
---|
| 3202 | return TCL_OK; |
---|
| 3203 | } |
---|
| 3204 | |
---|
| 3205 | /* |
---|
| 3206 | *---------------------------------------------------------------------- |
---|
| 3207 | * |
---|
| 3208 | * StringTrimRCmd -- |
---|
| 3209 | * |
---|
| 3210 | * This procedure is invoked to process the "string trimright" Tcl |
---|
| 3211 | * command. See the user documentation for details on what it does. Note |
---|
| 3212 | * that this command only functions correctly on properly formed Tcl UTF |
---|
| 3213 | * strings. |
---|
| 3214 | * |
---|
| 3215 | * Results: |
---|
| 3216 | * A standard Tcl result. |
---|
| 3217 | * |
---|
| 3218 | * Side effects: |
---|
| 3219 | * See the user documentation. |
---|
| 3220 | * |
---|
| 3221 | *---------------------------------------------------------------------- |
---|
| 3222 | */ |
---|
| 3223 | |
---|
| 3224 | static int |
---|
| 3225 | StringTrimRCmd( |
---|
| 3226 | ClientData dummy, /* Not used. */ |
---|
| 3227 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 3228 | int objc, /* Number of arguments. */ |
---|
| 3229 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 3230 | { |
---|
| 3231 | Tcl_UniChar ch, trim; |
---|
| 3232 | register const char *p, *end; |
---|
| 3233 | const char *check, *checkEnd, *string1, *string2; |
---|
| 3234 | int offset, length1, length2; |
---|
| 3235 | |
---|
| 3236 | if (objc == 3) { |
---|
| 3237 | string2 = TclGetStringFromObj(objv[2], &length2); |
---|
| 3238 | } else if (objc == 2) { |
---|
| 3239 | string2 = " \t\n\r"; |
---|
| 3240 | length2 = strlen(string2); |
---|
| 3241 | } else { |
---|
| 3242 | Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); |
---|
| 3243 | return TCL_ERROR; |
---|
| 3244 | } |
---|
| 3245 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
| 3246 | checkEnd = string2 + length2; |
---|
| 3247 | |
---|
| 3248 | /* |
---|
| 3249 | * The outer loop iterates over the string. The inner loop iterates over |
---|
| 3250 | * the trim characters. The loops terminate as soon as a non-trim |
---|
| 3251 | * character is discovered and length1 marks the last non-trim character. |
---|
| 3252 | */ |
---|
| 3253 | |
---|
| 3254 | end = string1; |
---|
| 3255 | for (p = string1 + length1; p > end; ) { |
---|
| 3256 | p = Tcl_UtfPrev(p, string1); |
---|
| 3257 | offset = TclUtfToUniChar(p, &ch); |
---|
| 3258 | check = string2; |
---|
| 3259 | while (1) { |
---|
| 3260 | if (check >= checkEnd) { |
---|
| 3261 | p = end; |
---|
| 3262 | break; |
---|
| 3263 | } |
---|
| 3264 | check += TclUtfToUniChar(check, &trim); |
---|
| 3265 | if (ch == trim) { |
---|
| 3266 | length1 -= offset; |
---|
| 3267 | break; |
---|
| 3268 | } |
---|
| 3269 | } |
---|
| 3270 | } |
---|
| 3271 | |
---|
| 3272 | Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); |
---|
| 3273 | return TCL_OK; |
---|
| 3274 | } |
---|
| 3275 | |
---|
| 3276 | /* |
---|
| 3277 | *---------------------------------------------------------------------- |
---|
| 3278 | * |
---|
| 3279 | * TclInitStringCmd -- |
---|
| 3280 | * |
---|
| 3281 | * This procedure creates the "string" Tcl command. See the user |
---|
| 3282 | * documentation for details on what it does. Note that this command only |
---|
| 3283 | * functions correctly on properly formed Tcl UTF strings. |
---|
| 3284 | * |
---|
| 3285 | * Also note that the primary methods here (equal, compare, match, ...) |
---|
| 3286 | * have bytecode equivalents. You will find the code for those in |
---|
| 3287 | * tclExecute.c. The code here will only be used in the non-bc case (like |
---|
| 3288 | * in an 'eval'). |
---|
| 3289 | * |
---|
| 3290 | * Results: |
---|
| 3291 | * A standard Tcl result. |
---|
| 3292 | * |
---|
| 3293 | * Side effects: |
---|
| 3294 | * See the user documentation. |
---|
| 3295 | * |
---|
| 3296 | *---------------------------------------------------------------------- |
---|
| 3297 | */ |
---|
| 3298 | |
---|
| 3299 | Tcl_Command |
---|
| 3300 | TclInitStringCmd( |
---|
| 3301 | Tcl_Interp *interp) /* Current interpreter. */ |
---|
| 3302 | { |
---|
| 3303 | static const EnsembleImplMap stringImplMap[] = { |
---|
| 3304 | {"bytelength", StringBytesCmd, NULL}, |
---|
| 3305 | {"compare", StringCmpCmd, TclCompileStringCmpCmd}, |
---|
| 3306 | {"equal", StringEqualCmd, TclCompileStringEqualCmd}, |
---|
| 3307 | {"first", StringFirstCmd, NULL}, |
---|
| 3308 | {"index", StringIndexCmd, TclCompileStringIndexCmd}, |
---|
| 3309 | {"is", StringIsCmd, NULL}, |
---|
| 3310 | {"last", StringLastCmd, NULL}, |
---|
| 3311 | {"length", StringLenCmd, TclCompileStringLenCmd}, |
---|
| 3312 | {"map", StringMapCmd, NULL}, |
---|
| 3313 | {"match", StringMatchCmd, TclCompileStringMatchCmd}, |
---|
| 3314 | {"range", StringRangeCmd, NULL}, |
---|
| 3315 | {"repeat", StringReptCmd, NULL}, |
---|
| 3316 | {"replace", StringRplcCmd, NULL}, |
---|
| 3317 | {"reverse", StringRevCmd, NULL}, |
---|
| 3318 | {"tolower", StringLowerCmd, NULL}, |
---|
| 3319 | {"toupper", StringUpperCmd, NULL}, |
---|
| 3320 | {"totitle", StringTitleCmd, NULL}, |
---|
| 3321 | {"trim", StringTrimCmd, NULL}, |
---|
| 3322 | {"trimleft", StringTrimLCmd, NULL}, |
---|
| 3323 | {"trimright", StringTrimRCmd, NULL}, |
---|
| 3324 | {"wordend", StringEndCmd, NULL}, |
---|
| 3325 | {"wordstart", StringStartCmd, NULL}, |
---|
| 3326 | {NULL} |
---|
| 3327 | }; |
---|
| 3328 | |
---|
| 3329 | return TclMakeEnsemble(interp, "string", stringImplMap); |
---|
| 3330 | } |
---|
| 3331 | |
---|
| 3332 | /* |
---|
| 3333 | *---------------------------------------------------------------------- |
---|
| 3334 | * |
---|
| 3335 | * Tcl_SubstObjCmd -- |
---|
| 3336 | * |
---|
| 3337 | * This procedure is invoked to process the "subst" Tcl command. See the |
---|
| 3338 | * user documentation for details on what it does. This command relies on |
---|
| 3339 | * Tcl_SubstObj() for its implementation. |
---|
| 3340 | * |
---|
| 3341 | * Results: |
---|
| 3342 | * A standard Tcl result. |
---|
| 3343 | * |
---|
| 3344 | * Side effects: |
---|
| 3345 | * See the user documentation. |
---|
| 3346 | * |
---|
| 3347 | *---------------------------------------------------------------------- |
---|
| 3348 | */ |
---|
| 3349 | |
---|
| 3350 | int |
---|
| 3351 | Tcl_SubstObjCmd( |
---|
| 3352 | ClientData dummy, /* Not used. */ |
---|
| 3353 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 3354 | int objc, /* Number of arguments. */ |
---|
| 3355 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 3356 | { |
---|
| 3357 | static CONST char *substOptions[] = { |
---|
| 3358 | "-nobackslashes", "-nocommands", "-novariables", NULL |
---|
| 3359 | }; |
---|
| 3360 | enum substOptions { |
---|
| 3361 | SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS |
---|
| 3362 | }; |
---|
| 3363 | Tcl_Obj *resultPtr; |
---|
| 3364 | int flags, i; |
---|
| 3365 | |
---|
| 3366 | /* |
---|
| 3367 | * Parse command-line options. |
---|
| 3368 | */ |
---|
| 3369 | |
---|
| 3370 | flags = TCL_SUBST_ALL; |
---|
| 3371 | for (i = 1; i < (objc-1); i++) { |
---|
| 3372 | int optionIndex; |
---|
| 3373 | |
---|
| 3374 | if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, |
---|
| 3375 | &optionIndex) != TCL_OK) { |
---|
| 3376 | return TCL_ERROR; |
---|
| 3377 | } |
---|
| 3378 | switch (optionIndex) { |
---|
| 3379 | case SUBST_NOBACKSLASHES: |
---|
| 3380 | flags &= ~TCL_SUBST_BACKSLASHES; |
---|
| 3381 | break; |
---|
| 3382 | case SUBST_NOCOMMANDS: |
---|
| 3383 | flags &= ~TCL_SUBST_COMMANDS; |
---|
| 3384 | break; |
---|
| 3385 | case SUBST_NOVARS: |
---|
| 3386 | flags &= ~TCL_SUBST_VARIABLES; |
---|
| 3387 | break; |
---|
| 3388 | default: |
---|
| 3389 | Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); |
---|
| 3390 | } |
---|
| 3391 | } |
---|
| 3392 | if (i != objc-1) { |
---|
| 3393 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 3394 | "?-nobackslashes? ?-nocommands? ?-novariables? string"); |
---|
| 3395 | return TCL_ERROR; |
---|
| 3396 | } |
---|
| 3397 | |
---|
| 3398 | /* |
---|
| 3399 | * Perform the substitution. |
---|
| 3400 | */ |
---|
| 3401 | |
---|
| 3402 | resultPtr = Tcl_SubstObj(interp, objv[i], flags); |
---|
| 3403 | |
---|
| 3404 | if (resultPtr == NULL) { |
---|
| 3405 | return TCL_ERROR; |
---|
| 3406 | } |
---|
| 3407 | Tcl_SetObjResult(interp, resultPtr); |
---|
| 3408 | return TCL_OK; |
---|
| 3409 | } |
---|
| 3410 | |
---|
| 3411 | /* |
---|
| 3412 | *---------------------------------------------------------------------- |
---|
| 3413 | * |
---|
| 3414 | * Tcl_SwitchObjCmd -- |
---|
| 3415 | * |
---|
| 3416 | * This object-based procedure is invoked to process the "switch" Tcl |
---|
| 3417 | * command. See the user documentation for details on what it does. |
---|
| 3418 | * |
---|
| 3419 | * Results: |
---|
| 3420 | * A standard Tcl object result. |
---|
| 3421 | * |
---|
| 3422 | * Side effects: |
---|
| 3423 | * See the user documentation. |
---|
| 3424 | * |
---|
| 3425 | *---------------------------------------------------------------------- |
---|
| 3426 | */ |
---|
| 3427 | |
---|
| 3428 | int |
---|
| 3429 | Tcl_SwitchObjCmd( |
---|
| 3430 | ClientData dummy, /* Not used. */ |
---|
| 3431 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 3432 | int objc, /* Number of arguments. */ |
---|
| 3433 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 3434 | { |
---|
| 3435 | int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved; |
---|
| 3436 | int noCase, patternLength; |
---|
| 3437 | char *pattern; |
---|
| 3438 | Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; |
---|
| 3439 | Tcl_Obj *CONST *savedObjv = objv; |
---|
| 3440 | Tcl_RegExp regExpr = NULL; |
---|
| 3441 | Interp *iPtr = (Interp *) interp; |
---|
| 3442 | int pc = 0; |
---|
| 3443 | int bidx = 0; /* Index of body argument. */ |
---|
| 3444 | Tcl_Obj *blist = NULL; /* List obj which is the body */ |
---|
| 3445 | CmdFrame *ctxPtr; /* Copy of the topmost cmdframe, to allow us |
---|
| 3446 | * to mess with the line information */ |
---|
| 3447 | |
---|
| 3448 | /* |
---|
| 3449 | * If you add options that make -e and -g not unique prefixes of -exact or |
---|
| 3450 | * -glob, you *must* fix TclCompileSwitchCmd's option parser as well. |
---|
| 3451 | */ |
---|
| 3452 | |
---|
| 3453 | static CONST char *options[] = { |
---|
| 3454 | "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", |
---|
| 3455 | "--", NULL |
---|
| 3456 | }; |
---|
| 3457 | enum options { |
---|
| 3458 | OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, |
---|
| 3459 | OPT_LAST |
---|
| 3460 | }; |
---|
| 3461 | typedef int (*strCmpFn_t)(const char *, const char *); |
---|
| 3462 | strCmpFn_t strCmpFn = strcmp; |
---|
| 3463 | |
---|
| 3464 | mode = OPT_EXACT; |
---|
| 3465 | foundmode = 0; |
---|
| 3466 | indexVarObj = NULL; |
---|
| 3467 | matchVarObj = NULL; |
---|
| 3468 | numMatchesSaved = 0; |
---|
| 3469 | noCase = 0; |
---|
| 3470 | for (i = 1; i < objc-2; i++) { |
---|
| 3471 | if (TclGetString(objv[i])[0] != '-') { |
---|
| 3472 | break; |
---|
| 3473 | } |
---|
| 3474 | if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, |
---|
| 3475 | &index) != TCL_OK) { |
---|
| 3476 | return TCL_ERROR; |
---|
| 3477 | } |
---|
| 3478 | switch ((enum options) index) { |
---|
| 3479 | /* |
---|
| 3480 | * General options. |
---|
| 3481 | */ |
---|
| 3482 | |
---|
| 3483 | case OPT_LAST: |
---|
| 3484 | i++; |
---|
| 3485 | goto finishedOptions; |
---|
| 3486 | case OPT_NOCASE: |
---|
| 3487 | strCmpFn = strcasecmp; |
---|
| 3488 | noCase = 1; |
---|
| 3489 | break; |
---|
| 3490 | |
---|
| 3491 | /* |
---|
| 3492 | * Handle the different switch mode options. |
---|
| 3493 | */ |
---|
| 3494 | |
---|
| 3495 | default: |
---|
| 3496 | if (foundmode) { |
---|
| 3497 | /* |
---|
| 3498 | * Mode already set via -exact, -glob, or -regexp. |
---|
| 3499 | */ |
---|
| 3500 | |
---|
| 3501 | Tcl_AppendResult(interp, "bad option \"", |
---|
| 3502 | TclGetString(objv[i]), "\": ", options[mode], |
---|
| 3503 | " option already found", NULL); |
---|
| 3504 | return TCL_ERROR; |
---|
| 3505 | } else { |
---|
| 3506 | foundmode = 1; |
---|
| 3507 | mode = index; |
---|
| 3508 | break; |
---|
| 3509 | } |
---|
| 3510 | |
---|
| 3511 | /* |
---|
| 3512 | * Check for TIP#75 options specifying the variables to write |
---|
| 3513 | * regexp information into. |
---|
| 3514 | */ |
---|
| 3515 | |
---|
| 3516 | case OPT_INDEXV: |
---|
| 3517 | i++; |
---|
| 3518 | if (i >= objc-2) { |
---|
| 3519 | Tcl_AppendResult(interp, "missing variable name argument to ", |
---|
| 3520 | "-indexvar", " option", NULL); |
---|
| 3521 | return TCL_ERROR; |
---|
| 3522 | } |
---|
| 3523 | indexVarObj = objv[i]; |
---|
| 3524 | numMatchesSaved = -1; |
---|
| 3525 | break; |
---|
| 3526 | case OPT_MATCHV: |
---|
| 3527 | i++; |
---|
| 3528 | if (i >= objc-2) { |
---|
| 3529 | Tcl_AppendResult(interp, "missing variable name argument to ", |
---|
| 3530 | "-matchvar", " option", NULL); |
---|
| 3531 | return TCL_ERROR; |
---|
| 3532 | } |
---|
| 3533 | matchVarObj = objv[i]; |
---|
| 3534 | numMatchesSaved = -1; |
---|
| 3535 | break; |
---|
| 3536 | } |
---|
| 3537 | } |
---|
| 3538 | |
---|
| 3539 | finishedOptions: |
---|
| 3540 | if (objc - i < 2) { |
---|
| 3541 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
| 3542 | "?switches? string pattern body ... ?default body?"); |
---|
| 3543 | return TCL_ERROR; |
---|
| 3544 | } |
---|
| 3545 | if (indexVarObj != NULL && mode != OPT_REGEXP) { |
---|
| 3546 | Tcl_AppendResult(interp, |
---|
| 3547 | "-indexvar option requires -regexp option", NULL); |
---|
| 3548 | return TCL_ERROR; |
---|
| 3549 | } |
---|
| 3550 | if (matchVarObj != NULL && mode != OPT_REGEXP) { |
---|
| 3551 | Tcl_AppendResult(interp, |
---|
| 3552 | "-matchvar option requires -regexp option", NULL); |
---|
| 3553 | return TCL_ERROR; |
---|
| 3554 | } |
---|
| 3555 | |
---|
| 3556 | stringObj = objv[i]; |
---|
| 3557 | objc -= i + 1; |
---|
| 3558 | objv += i + 1; |
---|
| 3559 | bidx = i + 1; /* First after the match string. */ |
---|
| 3560 | |
---|
| 3561 | /* |
---|
| 3562 | * If all of the pattern/command pairs are lumped into a single argument, |
---|
| 3563 | * split them out again. |
---|
| 3564 | * |
---|
| 3565 | * TIP #280: Determine the lines the words in the list start at, based on |
---|
| 3566 | * the same data for the list word itself. The cmdFramePtr line |
---|
| 3567 | * information is manipulated directly. |
---|
| 3568 | */ |
---|
| 3569 | |
---|
| 3570 | splitObjs = 0; |
---|
| 3571 | if (objc == 1) { |
---|
| 3572 | Tcl_Obj **listv; |
---|
| 3573 | blist = objv[0]; |
---|
| 3574 | |
---|
| 3575 | if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ |
---|
| 3576 | return TCL_ERROR; |
---|
| 3577 | } |
---|
| 3578 | |
---|
| 3579 | /* |
---|
| 3580 | * Ensure that the list is non-empty. |
---|
| 3581 | */ |
---|
| 3582 | |
---|
| 3583 | if (objc < 1) { |
---|
| 3584 | Tcl_WrongNumArgs(interp, 1, savedObjv, |
---|
| 3585 | "?switches? string {pattern body ... ?default body?}"); |
---|
| 3586 | return TCL_ERROR; |
---|
| 3587 | } |
---|
| 3588 | objv = listv; |
---|
| 3589 | splitObjs = 1; |
---|
| 3590 | } |
---|
| 3591 | |
---|
| 3592 | /* |
---|
| 3593 | * Complain if there is an odd number of words in the list of patterns and |
---|
| 3594 | * bodies. |
---|
| 3595 | */ |
---|
| 3596 | |
---|
| 3597 | if (objc % 2) { |
---|
| 3598 | Tcl_ResetResult(interp); |
---|
| 3599 | Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); |
---|
| 3600 | |
---|
| 3601 | /* |
---|
| 3602 | * Check if this can be due to a badly placed comment in the switch |
---|
| 3603 | * block. |
---|
| 3604 | * |
---|
| 3605 | * The following is an heuristic to detect the infamous "comment in |
---|
| 3606 | * switch" error: just check if a pattern begins with '#'. |
---|
| 3607 | */ |
---|
| 3608 | |
---|
| 3609 | if (splitObjs) { |
---|
| 3610 | for (i=0 ; i<objc ; i+=2) { |
---|
| 3611 | if (TclGetString(objv[i])[0] == '#') { |
---|
| 3612 | Tcl_AppendResult(interp, ", this may be due to a " |
---|
| 3613 | "comment incorrectly placed outside of a " |
---|
| 3614 | "switch body - see the \"switch\" " |
---|
| 3615 | "documentation", NULL); |
---|
| 3616 | break; |
---|
| 3617 | } |
---|
| 3618 | } |
---|
| 3619 | } |
---|
| 3620 | |
---|
| 3621 | return TCL_ERROR; |
---|
| 3622 | } |
---|
| 3623 | |
---|
| 3624 | /* |
---|
| 3625 | * Complain if the last body is a continuation. Note that this check |
---|
| 3626 | * assumes that the list is non-empty! |
---|
| 3627 | */ |
---|
| 3628 | |
---|
| 3629 | if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { |
---|
| 3630 | Tcl_ResetResult(interp); |
---|
| 3631 | Tcl_AppendResult(interp, "no body specified for pattern \"", |
---|
| 3632 | TclGetString(objv[objc-2]), "\"", NULL); |
---|
| 3633 | return TCL_ERROR; |
---|
| 3634 | } |
---|
| 3635 | |
---|
| 3636 | for (i = 0; i < objc; i += 2) { |
---|
| 3637 | /* |
---|
| 3638 | * See if the pattern matches the string. |
---|
| 3639 | */ |
---|
| 3640 | |
---|
| 3641 | pattern = TclGetStringFromObj(objv[i], &patternLength); |
---|
| 3642 | |
---|
| 3643 | if ((i == objc - 2) && (*pattern == 'd') |
---|
| 3644 | && (strcmp(pattern, "default") == 0)) { |
---|
| 3645 | Tcl_Obj *emptyObj = NULL; |
---|
| 3646 | |
---|
| 3647 | /* |
---|
| 3648 | * If either indexVarObj or matchVarObj are non-NULL, we're in |
---|
| 3649 | * REGEXP mode but have reached the default clause anyway. TIP#75 |
---|
| 3650 | * specifies that we set the variables to empty lists (== empty |
---|
| 3651 | * objects) in that case. |
---|
| 3652 | */ |
---|
| 3653 | |
---|
| 3654 | if (indexVarObj != NULL) { |
---|
| 3655 | TclNewObj(emptyObj); |
---|
| 3656 | if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, emptyObj, |
---|
| 3657 | TCL_LEAVE_ERR_MSG) == NULL) { |
---|
| 3658 | return TCL_ERROR; |
---|
| 3659 | } |
---|
| 3660 | } |
---|
| 3661 | if (matchVarObj != NULL) { |
---|
| 3662 | if (emptyObj == NULL) { |
---|
| 3663 | TclNewObj(emptyObj); |
---|
| 3664 | } |
---|
| 3665 | if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, emptyObj, |
---|
| 3666 | TCL_LEAVE_ERR_MSG) == NULL) { |
---|
| 3667 | return TCL_ERROR; |
---|
| 3668 | } |
---|
| 3669 | } |
---|
| 3670 | goto matchFound; |
---|
| 3671 | } else { |
---|
| 3672 | switch (mode) { |
---|
| 3673 | case OPT_EXACT: |
---|
| 3674 | if (strCmpFn(TclGetString(stringObj), pattern) == 0) { |
---|
| 3675 | goto matchFound; |
---|
| 3676 | } |
---|
| 3677 | break; |
---|
| 3678 | case OPT_GLOB: |
---|
| 3679 | if (Tcl_StringCaseMatch(TclGetString(stringObj), pattern, |
---|
| 3680 | noCase)) { |
---|
| 3681 | goto matchFound; |
---|
| 3682 | } |
---|
| 3683 | break; |
---|
| 3684 | case OPT_REGEXP: |
---|
| 3685 | regExpr = Tcl_GetRegExpFromObj(interp, objv[i], |
---|
| 3686 | TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); |
---|
| 3687 | if (regExpr == NULL) { |
---|
| 3688 | return TCL_ERROR; |
---|
| 3689 | } else { |
---|
| 3690 | int matched = Tcl_RegExpExecObj(interp, regExpr, |
---|
| 3691 | stringObj, 0, numMatchesSaved, 0); |
---|
| 3692 | |
---|
| 3693 | if (matched < 0) { |
---|
| 3694 | return TCL_ERROR; |
---|
| 3695 | } else if (matched) { |
---|
| 3696 | goto matchFoundRegexp; |
---|
| 3697 | } |
---|
| 3698 | } |
---|
| 3699 | break; |
---|
| 3700 | } |
---|
| 3701 | } |
---|
| 3702 | } |
---|
| 3703 | return TCL_OK; |
---|
| 3704 | |
---|
| 3705 | matchFoundRegexp: |
---|
| 3706 | /* |
---|
| 3707 | * We are operating in REGEXP mode and we need to store information about |
---|
| 3708 | * what we matched in some user-nominated arrays. So build the lists of |
---|
| 3709 | * values and indices to write here. [TIP#75] |
---|
| 3710 | */ |
---|
| 3711 | |
---|
| 3712 | if (numMatchesSaved) { |
---|
| 3713 | Tcl_RegExpInfo info; |
---|
| 3714 | Tcl_Obj *matchesObj, *indicesObj = NULL; |
---|
| 3715 | |
---|
| 3716 | Tcl_RegExpGetInfo(regExpr, &info); |
---|
| 3717 | if (matchVarObj != NULL) { |
---|
| 3718 | TclNewObj(matchesObj); |
---|
| 3719 | } else { |
---|
| 3720 | matchesObj = NULL; |
---|
| 3721 | } |
---|
| 3722 | if (indexVarObj != NULL) { |
---|
| 3723 | TclNewObj(indicesObj); |
---|
| 3724 | } |
---|
| 3725 | |
---|
| 3726 | for (j=0 ; j<=info.nsubs ; j++) { |
---|
| 3727 | if (indexVarObj != NULL) { |
---|
| 3728 | Tcl_Obj *rangeObjAry[2]; |
---|
| 3729 | |
---|
| 3730 | rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); |
---|
| 3731 | rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end); |
---|
| 3732 | |
---|
| 3733 | /* |
---|
| 3734 | * Never fails; the object is always clean at this point. |
---|
| 3735 | */ |
---|
| 3736 | |
---|
| 3737 | Tcl_ListObjAppendElement(NULL, indicesObj, |
---|
| 3738 | Tcl_NewListObj(2, rangeObjAry)); |
---|
| 3739 | } |
---|
| 3740 | |
---|
| 3741 | if (matchVarObj != NULL) { |
---|
| 3742 | Tcl_Obj *substringObj; |
---|
| 3743 | |
---|
| 3744 | substringObj = Tcl_GetRange(stringObj, |
---|
| 3745 | info.matches[j].start, info.matches[j].end-1); |
---|
| 3746 | |
---|
| 3747 | /* |
---|
| 3748 | * Never fails; the object is always clean at this point. |
---|
| 3749 | */ |
---|
| 3750 | |
---|
| 3751 | Tcl_ListObjAppendElement(NULL, matchesObj, substringObj); |
---|
| 3752 | } |
---|
| 3753 | } |
---|
| 3754 | |
---|
| 3755 | if (indexVarObj != NULL) { |
---|
| 3756 | if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj, |
---|
| 3757 | TCL_LEAVE_ERR_MSG) == NULL) { |
---|
| 3758 | /* |
---|
| 3759 | * Careful! Check to see if we have allocated the list of |
---|
| 3760 | * matched strings; if so (but there was an error assigning |
---|
| 3761 | * the indices list) we have a potential memory leak because |
---|
| 3762 | * the match list has not been written to a variable. Except |
---|
| 3763 | * that we'll clean that up right now. |
---|
| 3764 | */ |
---|
| 3765 | |
---|
| 3766 | if (matchesObj != NULL) { |
---|
| 3767 | Tcl_DecrRefCount(matchesObj); |
---|
| 3768 | } |
---|
| 3769 | return TCL_ERROR; |
---|
| 3770 | } |
---|
| 3771 | } |
---|
| 3772 | if (matchVarObj != NULL) { |
---|
| 3773 | if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj, |
---|
| 3774 | TCL_LEAVE_ERR_MSG) == NULL) { |
---|
| 3775 | /* |
---|
| 3776 | * Unlike above, if indicesObj is non-NULL at this point, it |
---|
| 3777 | * will have been written to a variable already and will hence |
---|
| 3778 | * not be leaked. |
---|
| 3779 | */ |
---|
| 3780 | |
---|
| 3781 | return TCL_ERROR; |
---|
| 3782 | } |
---|
| 3783 | } |
---|
| 3784 | } |
---|
| 3785 | |
---|
| 3786 | /* |
---|
| 3787 | * We've got a match. Find a body to execute, skipping bodies that are |
---|
| 3788 | * "-". |
---|
| 3789 | */ |
---|
| 3790 | |
---|
| 3791 | matchFound: |
---|
| 3792 | ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); |
---|
| 3793 | *ctxPtr = *iPtr->cmdFramePtr; |
---|
| 3794 | |
---|
| 3795 | if (splitObjs) { |
---|
| 3796 | /* |
---|
| 3797 | * We have to perform the GetSrc and other type dependent handling of |
---|
| 3798 | * the frame here because we are munging with the line numbers, |
---|
| 3799 | * something the other commands like if, etc. are not doing. Them are |
---|
| 3800 | * fine with simply passing the CmdFrame through and having the |
---|
| 3801 | * special handling done in 'info frame', or the bc compiler |
---|
| 3802 | */ |
---|
| 3803 | |
---|
| 3804 | if (ctxPtr->type == TCL_LOCATION_BC) { |
---|
| 3805 | /* |
---|
| 3806 | * Type BC => ctxPtr->data.eval.path is not used. |
---|
| 3807 | * ctxPtr->data.tebc.codePtr is used instead. |
---|
| 3808 | */ |
---|
| 3809 | |
---|
| 3810 | TclGetSrcInfoForPc(ctxPtr); |
---|
| 3811 | pc = 1; |
---|
| 3812 | |
---|
| 3813 | /* |
---|
| 3814 | * The line information in the cmdFrame is now a copy we do not |
---|
| 3815 | * own. |
---|
| 3816 | */ |
---|
| 3817 | } |
---|
| 3818 | |
---|
| 3819 | if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { |
---|
| 3820 | int bline = ctxPtr->line[bidx]; |
---|
| 3821 | |
---|
| 3822 | ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); |
---|
| 3823 | ctxPtr->nline = objc; |
---|
| 3824 | TclListLines(TclGetString(blist), bline, objc, ctxPtr->line); |
---|
| 3825 | } else { |
---|
| 3826 | /* |
---|
| 3827 | * This is either a dynamic code word, when all elements are |
---|
| 3828 | * relative to themselves, or something else less expected and |
---|
| 3829 | * where we have no information. The result is the same in both |
---|
| 3830 | * cases; tell the code to come that it doesn't know where it is, |
---|
| 3831 | * which triggers reversion to the old behavior. |
---|
| 3832 | */ |
---|
| 3833 | |
---|
| 3834 | int k; |
---|
| 3835 | |
---|
| 3836 | ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); |
---|
| 3837 | ctxPtr->nline = objc; |
---|
| 3838 | for (k=0; k < objc; k++) { |
---|
| 3839 | ctxPtr->line[k] = -1; |
---|
| 3840 | } |
---|
| 3841 | } |
---|
| 3842 | } |
---|
| 3843 | |
---|
| 3844 | for (j = i + 1; ; j += 2) { |
---|
| 3845 | if (j >= objc) { |
---|
| 3846 | /* |
---|
| 3847 | * This shouldn't happen since we've checked that the last body is |
---|
| 3848 | * not a continuation... |
---|
| 3849 | */ |
---|
| 3850 | |
---|
| 3851 | Tcl_Panic("fall-out when searching for body to match pattern"); |
---|
| 3852 | } |
---|
| 3853 | if (strcmp(TclGetString(objv[j]), "-") != 0) { |
---|
| 3854 | break; |
---|
| 3855 | } |
---|
| 3856 | } |
---|
| 3857 | |
---|
| 3858 | /* |
---|
| 3859 | * TIP #280: Make invoking context available to switch branch. |
---|
| 3860 | */ |
---|
| 3861 | |
---|
| 3862 | result = TclEvalObjEx(interp, objv[j], 0, ctxPtr, j); |
---|
| 3863 | if (splitObjs) { |
---|
| 3864 | ckfree((char *) ctxPtr->line); |
---|
| 3865 | if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { |
---|
| 3866 | /* |
---|
| 3867 | * Death of SrcInfo reference. |
---|
| 3868 | */ |
---|
| 3869 | |
---|
| 3870 | Tcl_DecrRefCount(ctxPtr->data.eval.path); |
---|
| 3871 | } |
---|
| 3872 | } |
---|
| 3873 | |
---|
| 3874 | /* |
---|
| 3875 | * Generate an error message if necessary. |
---|
| 3876 | */ |
---|
| 3877 | |
---|
| 3878 | if (result == TCL_ERROR) { |
---|
| 3879 | int limit = 50; |
---|
| 3880 | int overflow = (patternLength > limit); |
---|
| 3881 | |
---|
| 3882 | Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
---|
| 3883 | "\n (\"%.*s%s\" arm line %d)", |
---|
| 3884 | (overflow ? limit : patternLength), pattern, |
---|
| 3885 | (overflow ? "..." : ""), interp->errorLine)); |
---|
| 3886 | } |
---|
| 3887 | TclStackFree(interp, ctxPtr); |
---|
| 3888 | return result; |
---|
| 3889 | } |
---|
| 3890 | |
---|
| 3891 | /* |
---|
| 3892 | *---------------------------------------------------------------------- |
---|
| 3893 | * |
---|
| 3894 | * Tcl_TimeObjCmd -- |
---|
| 3895 | * |
---|
| 3896 | * This object-based procedure is invoked to process the "time" Tcl |
---|
| 3897 | * command. See the user documentation for details on what it does. |
---|
| 3898 | * |
---|
| 3899 | * Results: |
---|
| 3900 | * A standard Tcl object result. |
---|
| 3901 | * |
---|
| 3902 | * Side effects: |
---|
| 3903 | * See the user documentation. |
---|
| 3904 | * |
---|
| 3905 | *---------------------------------------------------------------------- |
---|
| 3906 | */ |
---|
| 3907 | |
---|
| 3908 | int |
---|
| 3909 | Tcl_TimeObjCmd( |
---|
| 3910 | ClientData dummy, /* Not used. */ |
---|
| 3911 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 3912 | int objc, /* Number of arguments. */ |
---|
| 3913 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 3914 | { |
---|
| 3915 | register Tcl_Obj *objPtr; |
---|
| 3916 | Tcl_Obj *objs[4]; |
---|
| 3917 | register int i, result; |
---|
| 3918 | int count; |
---|
| 3919 | double totalMicroSec; |
---|
| 3920 | #ifndef TCL_WIDE_CLICKS |
---|
| 3921 | Tcl_Time start, stop; |
---|
| 3922 | #else |
---|
| 3923 | Tcl_WideInt start, stop; |
---|
| 3924 | #endif |
---|
| 3925 | |
---|
| 3926 | if (objc == 2) { |
---|
| 3927 | count = 1; |
---|
| 3928 | } else if (objc == 3) { |
---|
| 3929 | result = TclGetIntFromObj(interp, objv[2], &count); |
---|
| 3930 | if (result != TCL_OK) { |
---|
| 3931 | return result; |
---|
| 3932 | } |
---|
| 3933 | } else { |
---|
| 3934 | Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); |
---|
| 3935 | return TCL_ERROR; |
---|
| 3936 | } |
---|
| 3937 | |
---|
| 3938 | objPtr = objv[1]; |
---|
| 3939 | i = count; |
---|
| 3940 | #ifndef TCL_WIDE_CLICKS |
---|
| 3941 | Tcl_GetTime(&start); |
---|
| 3942 | #else |
---|
| 3943 | start = TclpGetWideClicks(); |
---|
| 3944 | #endif |
---|
| 3945 | while (i-- > 0) { |
---|
| 3946 | result = Tcl_EvalObjEx(interp, objPtr, 0); |
---|
| 3947 | if (result != TCL_OK) { |
---|
| 3948 | return result; |
---|
| 3949 | } |
---|
| 3950 | } |
---|
| 3951 | #ifndef TCL_WIDE_CLICKS |
---|
| 3952 | Tcl_GetTime(&stop); |
---|
| 3953 | totalMicroSec = ((double) (stop.sec - start.sec)) * 1.0e6 |
---|
| 3954 | + (stop.usec - start.usec); |
---|
| 3955 | #else |
---|
| 3956 | stop = TclpGetWideClicks(); |
---|
| 3957 | totalMicroSec = ((double) TclpWideClicksToNanoseconds(stop - start))/1.0e3; |
---|
| 3958 | #endif |
---|
| 3959 | |
---|
| 3960 | if (count <= 1) { |
---|
| 3961 | /* |
---|
| 3962 | * Use int obj since we know time is not fractional. [Bug 1202178] |
---|
| 3963 | */ |
---|
| 3964 | |
---|
| 3965 | objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); |
---|
| 3966 | } else { |
---|
| 3967 | objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); |
---|
| 3968 | } |
---|
| 3969 | |
---|
| 3970 | /* |
---|
| 3971 | * Construct the result as a list because many programs have always parsed |
---|
| 3972 | * as such (extracting the first element, typically). |
---|
| 3973 | */ |
---|
| 3974 | |
---|
| 3975 | TclNewLiteralStringObj(objs[1], "microseconds"); |
---|
| 3976 | TclNewLiteralStringObj(objs[2], "per"); |
---|
| 3977 | TclNewLiteralStringObj(objs[3], "iteration"); |
---|
| 3978 | Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs)); |
---|
| 3979 | |
---|
| 3980 | return TCL_OK; |
---|
| 3981 | } |
---|
| 3982 | |
---|
| 3983 | /* |
---|
| 3984 | *---------------------------------------------------------------------- |
---|
| 3985 | * |
---|
| 3986 | * Tcl_WhileObjCmd -- |
---|
| 3987 | * |
---|
| 3988 | * This procedure is invoked to process the "while" Tcl command. See the |
---|
| 3989 | * user documentation for details on what it does. |
---|
| 3990 | * |
---|
| 3991 | * With the bytecode compiler, this procedure is only called when a |
---|
| 3992 | * command name is computed at runtime, and is "while" or the name to |
---|
| 3993 | * which "while" was renamed: e.g., "set z while; $z {$i<100} {}" |
---|
| 3994 | * |
---|
| 3995 | * Results: |
---|
| 3996 | * A standard Tcl result. |
---|
| 3997 | * |
---|
| 3998 | * Side effects: |
---|
| 3999 | * See the user documentation. |
---|
| 4000 | * |
---|
| 4001 | *---------------------------------------------------------------------- |
---|
| 4002 | */ |
---|
| 4003 | |
---|
| 4004 | int |
---|
| 4005 | Tcl_WhileObjCmd( |
---|
| 4006 | ClientData dummy, /* Not used. */ |
---|
| 4007 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 4008 | int objc, /* Number of arguments. */ |
---|
| 4009 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 4010 | { |
---|
| 4011 | int result, value; |
---|
| 4012 | Interp *iPtr = (Interp *) interp; |
---|
| 4013 | |
---|
| 4014 | if (objc != 3) { |
---|
| 4015 | Tcl_WrongNumArgs(interp, 1, objv, "test command"); |
---|
| 4016 | return TCL_ERROR; |
---|
| 4017 | } |
---|
| 4018 | |
---|
| 4019 | while (1) { |
---|
| 4020 | result = Tcl_ExprBooleanObj(interp, objv[1], &value); |
---|
| 4021 | if (result != TCL_OK) { |
---|
| 4022 | return result; |
---|
| 4023 | } |
---|
| 4024 | if (!value) { |
---|
| 4025 | break; |
---|
| 4026 | } |
---|
| 4027 | |
---|
| 4028 | /* TIP #280. */ |
---|
| 4029 | result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr, 2); |
---|
| 4030 | if ((result != TCL_OK) && (result != TCL_CONTINUE)) { |
---|
| 4031 | if (result == TCL_ERROR) { |
---|
| 4032 | Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
---|
| 4033 | "\n (\"while\" body line %d)", interp->errorLine)); |
---|
| 4034 | } |
---|
| 4035 | break; |
---|
| 4036 | } |
---|
| 4037 | } |
---|
| 4038 | if (result == TCL_BREAK) { |
---|
| 4039 | result = TCL_OK; |
---|
| 4040 | } |
---|
| 4041 | if (result == TCL_OK) { |
---|
| 4042 | Tcl_ResetResult(interp); |
---|
| 4043 | } |
---|
| 4044 | return result; |
---|
| 4045 | } |
---|
| 4046 | |
---|
| 4047 | /* |
---|
| 4048 | *---------------------------------------------------------------------- |
---|
| 4049 | * |
---|
| 4050 | * TclListLines -- |
---|
| 4051 | * |
---|
| 4052 | * ??? |
---|
| 4053 | * |
---|
| 4054 | * Results: |
---|
| 4055 | * Filled in array of line numbers? |
---|
| 4056 | * |
---|
| 4057 | * Side effects: |
---|
| 4058 | * None. |
---|
| 4059 | * |
---|
| 4060 | *---------------------------------------------------------------------- |
---|
| 4061 | */ |
---|
| 4062 | |
---|
| 4063 | void |
---|
| 4064 | TclListLines( |
---|
| 4065 | CONST char *listStr, /* Pointer to string with list structure. |
---|
| 4066 | * Assumed to be valid. Assumed to contain n |
---|
| 4067 | * elements. */ |
---|
| 4068 | int line, /* Line the list as a whole starts on. */ |
---|
| 4069 | int n, /* #elements in lines */ |
---|
| 4070 | int *lines) /* Array of line numbers, to fill. */ |
---|
| 4071 | { |
---|
| 4072 | int i, length = strlen(listStr); |
---|
| 4073 | CONST char *element = NULL, *next = NULL; |
---|
| 4074 | |
---|
| 4075 | for (i = 0; i < n; i++) { |
---|
| 4076 | TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL); |
---|
| 4077 | |
---|
| 4078 | TclAdvanceLines(&line, listStr, element); |
---|
| 4079 | /* Leading whitespace */ |
---|
| 4080 | lines[i] = line; |
---|
| 4081 | length -= (next - listStr); |
---|
| 4082 | TclAdvanceLines(&line, element, next); |
---|
| 4083 | /* Element */ |
---|
| 4084 | listStr = next; |
---|
| 4085 | |
---|
| 4086 | if (*element == 0) { |
---|
| 4087 | /* ASSERT i == n */ |
---|
| 4088 | break; |
---|
| 4089 | } |
---|
| 4090 | } |
---|
| 4091 | } |
---|
| 4092 | |
---|
| 4093 | /* |
---|
| 4094 | * Local Variables: |
---|
| 4095 | * mode: c |
---|
| 4096 | * c-basic-offset: 4 |
---|
| 4097 | * fill-column: 78 |
---|
| 4098 | * End: |
---|
| 4099 | */ |
---|