1/* 2 * tclCmdIL.c -- 3 * 4 * This file contains the top-level command routines for most of 5 * the Tcl built-in commands whose names begin with the letters 6 * I through L. It contains only commands in the generic core 7 * (i.e. those that don't depend much upon UNIX facilities). 8 * 9 * Copyright (c) 1987-1993 The Regents of the University of California. 10 * Copyright (c) 1993-1997 Lucent Technologies. 11 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 12 * Copyright (c) 1998-1999 by Scriptics Corporation. 13 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. 14 * 15 * See the file "license.terms" for information on usage and redistribution 16 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 17 * 18 * RCS: @(#) $Id: tclCmdIL.c,v 1.47.2.12 2007/12/05 14:54:08 dkf Exp $ 19 */ 20 21#include "tclInt.h" 22#include "tclPort.h" 23#include "tclRegexp.h" 24 25/* 26 * During execution of the "lsort" command, structures of the following 27 * type are used to arrange the objects being sorted into a collection 28 * of linked lists. 29 */ 30 31typedef struct SortElement { 32 Tcl_Obj *objPtr; /* Object being sorted. */ 33 int count; /* number of same elements in list */ 34 struct SortElement *nextPtr; /* Next element in the list, or 35 * NULL for end of list. */ 36} SortElement; 37 38/* 39 * The "lsort" command needs to pass certain information down to the 40 * function that compares two list elements, and the comparison function 41 * needs to pass success or failure information back up to the top-level 42 * "lsort" command. The following structure is used to pass this 43 * information. 44 */ 45 46typedef struct SortInfo { 47 int isIncreasing; /* Nonzero means sort in increasing order. */ 48 int sortMode; /* The sort mode. One of SORTMODE_* 49 * values defined below */ 50 Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode 51 * is SORTMODE_COMMAND. Pre-initialized to 52 * hold base of command.*/ 53 int index; /* If the -index option was specified, this 54 * holds the index of the list element 55 * to extract for comparison. If -index 56 * wasn't specified, this is -1. */ 57 Tcl_Interp *interp; /* The interpreter in which the sortis 58 * being done. */ 59 int resultCode; /* Completion code for the lsort command. 60 * If an error occurs during the sort this 61 * is changed from TCL_OK to TCL_ERROR. */ 62} SortInfo; 63 64/* 65 * The "sortMode" field of the SortInfo structure can take on any of the 66 * following values. 67 */ 68 69#define SORTMODE_ASCII 0 70#define SORTMODE_INTEGER 1 71#define SORTMODE_REAL 2 72#define SORTMODE_COMMAND 3 73#define SORTMODE_DICTIONARY 4 74 75/* 76 * Magic values for the index field of the SortInfo structure. 77 * Note that the index "end-1" will be translated to SORTIDX_END-1, etc. 78 */ 79#define SORTIDX_NONE -1 /* Not indexed; use whole value. */ 80#define SORTIDX_END -2 /* Indexed from end. */ 81 82/* 83 * Forward declarations for procedures defined in this file: 84 */ 85 86static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp, 87 Tcl_Obj *listPtr, CONST char *pattern, 88 int includeLinks)); 89static int DictionaryCompare _ANSI_ARGS_((char *left, 90 char *right)); 91static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy, 92 Tcl_Interp *interp, int objc, 93 Tcl_Obj *CONST objv[])); 94static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy, 95 Tcl_Interp *interp, int objc, 96 Tcl_Obj *CONST objv[])); 97static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy, 98 Tcl_Interp *interp, int objc, 99 Tcl_Obj *CONST objv[])); 100static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy, 101 Tcl_Interp *interp, int objc, 102 Tcl_Obj *CONST objv[])); 103static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy, 104 Tcl_Interp *interp, int objc, 105 Tcl_Obj *CONST objv[])); 106static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy, 107 Tcl_Interp *interp, int objc, 108 Tcl_Obj *CONST objv[])); 109static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy, 110 Tcl_Interp *interp, int objc, 111 Tcl_Obj *CONST objv[])); 112#ifdef TCL_TIP280 113/* TIP #280 - New 'info' subcommand 'frame' */ 114static int InfoFrameCmd _ANSI_ARGS_((ClientData dummy, 115 Tcl_Interp *interp, int objc, 116 Tcl_Obj *CONST objv[])); 117#endif 118static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy, 119 Tcl_Interp *interp, int objc, 120 Tcl_Obj *CONST objv[])); 121static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy, 122 Tcl_Interp *interp, int objc, 123 Tcl_Obj *CONST objv[])); 124static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy, 125 Tcl_Interp *interp, int objc, 126 Tcl_Obj *CONST objv[])); 127static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy, 128 Tcl_Interp *interp, int objc, 129 Tcl_Obj *CONST objv[])); 130static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy, 131 Tcl_Interp *interp, int objc, 132 Tcl_Obj *CONST objv[])); 133static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy, 134 Tcl_Interp *interp, int objc, 135 Tcl_Obj *CONST objv[])); 136static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy, 137 Tcl_Interp *interp, int objc, 138 Tcl_Obj *CONST objv[])); 139static int InfoNameOfExecutableCmd _ANSI_ARGS_(( 140 ClientData dummy, Tcl_Interp *interp, int objc, 141 Tcl_Obj *CONST objv[])); 142static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy, 143 Tcl_Interp *interp, int objc, 144 Tcl_Obj *CONST objv[])); 145static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy, 146 Tcl_Interp *interp, int objc, 147 Tcl_Obj *CONST objv[])); 148static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy, 149 Tcl_Interp *interp, int objc, 150 Tcl_Obj *CONST objv[])); 151static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy, 152 Tcl_Interp *interp, int objc, 153 Tcl_Obj *CONST objv[])); 154static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy, 155 Tcl_Interp *interp, int objc, 156 Tcl_Obj *CONST objv[])); 157static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy, 158 Tcl_Interp *interp, int objc, 159 Tcl_Obj *CONST objv[])); 160static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt, 161 SortInfo *infoPtr)); 162static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr, 163 SortElement *rightPtr, SortInfo *infoPtr)); 164static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr, 165 Tcl_Obj *second, SortInfo *infoPtr)); 166 167/* 168 *---------------------------------------------------------------------- 169 * 170 * Tcl_IfObjCmd -- 171 * 172 * This procedure is invoked to process the "if" Tcl command. 173 * See the user documentation for details on what it does. 174 * 175 * With the bytecode compiler, this procedure is only called when 176 * a command name is computed at runtime, and is "if" or the name 177 * to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}" 178 * 179 * Results: 180 * A standard Tcl result. 181 * 182 * Side effects: 183 * See the user documentation. 184 * 185 *---------------------------------------------------------------------- 186 */ 187 188 /* ARGSUSED */ 189int 190Tcl_IfObjCmd(dummy, interp, objc, objv) 191 ClientData dummy; /* Not used. */ 192 Tcl_Interp *interp; /* Current interpreter. */ 193 int objc; /* Number of arguments. */ 194 Tcl_Obj *CONST objv[]; /* Argument objects. */ 195{ 196 int thenScriptIndex = 0; /* then script to be evaled after syntax check */ 197#ifdef TCL_TIP280 198 Interp* iPtr = (Interp*) interp; 199#endif 200 int i, result, value; 201 char *clause; 202 i = 1; 203 while (1) { 204 /* 205 * At this point in the loop, objv and objc refer to an expression 206 * to test, either for the main expression or an expression 207 * following an "elseif". The arguments after the expression must 208 * be "then" (optional) and a script to execute if the expression is 209 * true. 210 */ 211 212 if (i >= objc) { 213 clause = Tcl_GetString(objv[i-1]); 214 Tcl_AppendResult(interp, "wrong # args: no expression after \"", 215 clause, "\" argument", (char *) NULL); 216 return TCL_ERROR; 217 } 218 if (!thenScriptIndex) { 219 result = Tcl_ExprBooleanObj(interp, objv[i], &value); 220 if (result != TCL_OK) { 221 return result; 222 } 223 } 224 i++; 225 if (i >= objc) { 226 missingScript: 227 clause = Tcl_GetString(objv[i-1]); 228 Tcl_AppendResult(interp, "wrong # args: no script following \"", 229 clause, "\" argument", (char *) NULL); 230 return TCL_ERROR; 231 } 232 clause = Tcl_GetString(objv[i]); 233 if ((i < objc) && (strcmp(clause, "then") == 0)) { 234 i++; 235 } 236 if (i >= objc) { 237 goto missingScript; 238 } 239 if (value) { 240 thenScriptIndex = i; 241 value = 0; 242 } 243 244 /* 245 * The expression evaluated to false. Skip the command, then 246 * see if there is an "else" or "elseif" clause. 247 */ 248 249 i++; 250 if (i >= objc) { 251 if (thenScriptIndex) { 252#ifndef TCL_TIP280 253 return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); 254#else 255 /* TIP #280. Make invoking context available to branch */ 256 return TclEvalObjEx(interp, objv[thenScriptIndex], 0, 257 iPtr->cmdFramePtr,thenScriptIndex); 258#endif 259 } 260 return TCL_OK; 261 } 262 clause = Tcl_GetString(objv[i]); 263 if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) { 264 i++; 265 continue; 266 } 267 break; 268 } 269 270 /* 271 * Couldn't find a "then" or "elseif" clause to execute. Check now 272 * for an "else" clause. We know that there's at least one more 273 * argument when we get here. 274 */ 275 276 if (strcmp(clause, "else") == 0) { 277 i++; 278 if (i >= objc) { 279 Tcl_AppendResult(interp, 280 "wrong # args: no script following \"else\" argument", 281 (char *) NULL); 282 return TCL_ERROR; 283 } 284 } 285 if (i < objc - 1) { 286 Tcl_AppendResult(interp, 287 "wrong # args: extra words after \"else\" clause in \"if\" command", 288 (char *) NULL); 289 return TCL_ERROR; 290 } 291 if (thenScriptIndex) { 292#ifndef TCL_TIP280 293 return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); 294#else 295 /* TIP #280. Make invoking context available to branch/else */ 296 return TclEvalObjEx(interp, objv[thenScriptIndex], 0, 297 iPtr->cmdFramePtr,thenScriptIndex); 298#endif 299 } 300#ifndef TCL_TIP280 301 return Tcl_EvalObjEx(interp, objv[i], 0); 302#else 303 return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i); 304#endif 305} 306 307/* 308 *---------------------------------------------------------------------- 309 * 310 * Tcl_IncrObjCmd -- 311 * 312 * This procedure is invoked to process the "incr" Tcl command. 313 * See the user documentation for details on what it does. 314 * 315 * With the bytecode compiler, this procedure is only called when 316 * a command name is computed at runtime, and is "incr" or the name 317 * to which "incr" was renamed: e.g., "set z incr; $z i -1" 318 * 319 * Results: 320 * A standard Tcl result. 321 * 322 * Side effects: 323 * See the user documentation. 324 * 325 *---------------------------------------------------------------------- 326 */ 327 328 /* ARGSUSED */ 329int 330Tcl_IncrObjCmd(dummy, interp, objc, objv) 331 ClientData dummy; /* Not used. */ 332 Tcl_Interp *interp; /* Current interpreter. */ 333 int objc; /* Number of arguments. */ 334 Tcl_Obj *CONST objv[]; /* Argument objects. */ 335{ 336 long incrAmount; 337 Tcl_Obj *newValuePtr; 338 339 if ((objc != 2) && (objc != 3)) { 340 Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); 341 return TCL_ERROR; 342 } 343 344 /* 345 * Calculate the amount to increment by. 346 */ 347 348 if (objc == 2) { 349 incrAmount = 1; 350 } else { 351 if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) { 352 Tcl_AddErrorInfo(interp, "\n (reading increment)"); 353 return TCL_ERROR; 354 } 355 /* 356 * Need to be a bit cautious to ensure that [expr]-like rules 357 * are enforced for interpretation of wide integers, despite 358 * the fact that the underlying API itself is a 'long' only one. 359 */ 360 if (objv[2]->typePtr == &tclIntType) { 361 incrAmount = objv[2]->internalRep.longValue; 362 } else if (objv[2]->typePtr == &tclWideIntType) { 363 TclGetLongFromWide(incrAmount,objv[2]); 364 } else { 365 Tcl_WideInt wide; 366 367 if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) { 368 Tcl_AddErrorInfo(interp, "\n (reading increment)"); 369 return TCL_ERROR; 370 } 371 incrAmount = Tcl_WideAsLong(wide); 372 if ((wide <= Tcl_LongAsWide(LONG_MAX)) 373 && (wide >= Tcl_LongAsWide(LONG_MIN))) { 374 objv[2]->typePtr = &tclIntType; 375 objv[2]->internalRep.longValue = incrAmount; 376 } 377 } 378 } 379 380 /* 381 * Increment the variable's value. 382 */ 383 384 newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount, 385 TCL_LEAVE_ERR_MSG); 386 if (newValuePtr == NULL) { 387 return TCL_ERROR; 388 } 389 390 /* 391 * Set the interpreter's object result to refer to the variable's new 392 * value object. 393 */ 394 395 Tcl_SetObjResult(interp, newValuePtr); 396 return TCL_OK; 397} 398 399/* 400 *---------------------------------------------------------------------- 401 * 402 * Tcl_InfoObjCmd -- 403 * 404 * This procedure is invoked to process the "info" Tcl command. 405 * See the user documentation for details on what it does. 406 * 407 * Results: 408 * A standard Tcl result. 409 * 410 * Side effects: 411 * See the user documentation. 412 * 413 *---------------------------------------------------------------------- 414 */ 415 416 /* ARGSUSED */ 417int 418Tcl_InfoObjCmd(clientData, interp, objc, objv) 419 ClientData clientData; /* Arbitrary value passed to the command. */ 420 Tcl_Interp *interp; /* Current interpreter. */ 421 int objc; /* Number of arguments. */ 422 Tcl_Obj *CONST objv[]; /* Argument objects. */ 423{ 424 static CONST char *subCmds[] = { 425 "args", "body", "cmdcount", "commands", 426 "complete", "default", "exists", 427#ifdef TCL_TIP280 428 "frame", 429#endif 430 "functions", 431 "globals", "hostname", "level", "library", "loaded", 432 "locals", "nameofexecutable", "patchlevel", "procs", 433 "script", "sharedlibextension", "tclversion", "vars", 434 (char *) NULL}; 435 enum ISubCmdIdx { 436 IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, 437 ICompleteIdx, IDefaultIdx, IExistsIdx, 438#ifdef TCL_TIP280 439 IFrameIdx, 440#endif 441 IFunctionsIdx, 442 IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, 443 ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, 444 IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx 445 }; 446 int index, result; 447 448 if (objc < 2) { 449 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); 450 return TCL_ERROR; 451 } 452 453 result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, 454 (int *) &index); 455 if (result != TCL_OK) { 456 return result; 457 } 458 459 switch (index) { 460 case IArgsIdx: 461 result = InfoArgsCmd(clientData, interp, objc, objv); 462 break; 463 case IBodyIdx: 464 result = InfoBodyCmd(clientData, interp, objc, objv); 465 break; 466 case ICmdCountIdx: 467 result = InfoCmdCountCmd(clientData, interp, objc, objv); 468 break; 469 case ICommandsIdx: 470 result = InfoCommandsCmd(clientData, interp, objc, objv); 471 break; 472 case ICompleteIdx: 473 result = InfoCompleteCmd(clientData, interp, objc, objv); 474 break; 475 case IDefaultIdx: 476 result = InfoDefaultCmd(clientData, interp, objc, objv); 477 break; 478 case IExistsIdx: 479 result = InfoExistsCmd(clientData, interp, objc, objv); 480 break; 481#ifdef TCL_TIP280 482 case IFrameIdx: 483 /* TIP #280 - New method 'frame' */ 484 result = InfoFrameCmd(clientData, interp, objc, objv); 485 break; 486#endif 487 case IFunctionsIdx: 488 result = InfoFunctionsCmd(clientData, interp, objc, objv); 489 break; 490 case IGlobalsIdx: 491 result = InfoGlobalsCmd(clientData, interp, objc, objv); 492 break; 493 case IHostnameIdx: 494 result = InfoHostnameCmd(clientData, interp, objc, objv); 495 break; 496 case ILevelIdx: 497 result = InfoLevelCmd(clientData, interp, objc, objv); 498 break; 499 case ILibraryIdx: 500 result = InfoLibraryCmd(clientData, interp, objc, objv); 501 break; 502 case ILoadedIdx: 503 result = InfoLoadedCmd(clientData, interp, objc, objv); 504 break; 505 case ILocalsIdx: 506 result = InfoLocalsCmd(clientData, interp, objc, objv); 507 break; 508 case INameOfExecutableIdx: 509 result = InfoNameOfExecutableCmd(clientData, interp, objc, objv); 510 break; 511 case IPatchLevelIdx: 512 result = InfoPatchLevelCmd(clientData, interp, objc, objv); 513 break; 514 case IProcsIdx: 515 result = InfoProcsCmd(clientData, interp, objc, objv); 516 break; 517 case IScriptIdx: 518 result = InfoScriptCmd(clientData, interp, objc, objv); 519 break; 520 case ISharedLibExtensionIdx: 521 result = InfoSharedlibCmd(clientData, interp, objc, objv); 522 break; 523 case ITclVersionIdx: 524 result = InfoTclVersionCmd(clientData, interp, objc, objv); 525 break; 526 case IVarsIdx: 527 result = InfoVarsCmd(clientData, interp, objc, objv); 528 break; 529 } 530 return result; 531} 532 533/* 534 *---------------------------------------------------------------------- 535 * 536 * InfoArgsCmd -- 537 * 538 * Called to implement the "info args" command that returns the 539 * argument list for a procedure. Handles the following syntax: 540 * 541 * info args procName 542 * 543 * Results: 544 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 545 * 546 * Side effects: 547 * Returns a result in the interpreter's result object. If there is 548 * an error, the result is an error message. 549 * 550 *---------------------------------------------------------------------- 551 */ 552 553static int 554InfoArgsCmd(dummy, interp, objc, objv) 555 ClientData dummy; /* Not used. */ 556 Tcl_Interp *interp; /* Current interpreter. */ 557 int objc; /* Number of arguments. */ 558 Tcl_Obj *CONST objv[]; /* Argument objects. */ 559{ 560 register Interp *iPtr = (Interp *) interp; 561 char *name; 562 Proc *procPtr; 563 CompiledLocal *localPtr; 564 Tcl_Obj *listObjPtr; 565 566 if (objc != 3) { 567 Tcl_WrongNumArgs(interp, 2, objv, "procname"); 568 return TCL_ERROR; 569 } 570 571 name = Tcl_GetString(objv[2]); 572 procPtr = TclFindProc(iPtr, name); 573 if (procPtr == NULL) { 574 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 575 "\"", name, "\" isn't a procedure", (char *) NULL); 576 return TCL_ERROR; 577 } 578 579 /* 580 * Build a return list containing the arguments. 581 */ 582 583 listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 584 for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; 585 localPtr = localPtr->nextPtr) { 586 if (TclIsVarArgument(localPtr)) { 587 Tcl_ListObjAppendElement(interp, listObjPtr, 588 Tcl_NewStringObj(localPtr->name, -1)); 589 } 590 } 591 Tcl_SetObjResult(interp, listObjPtr); 592 return TCL_OK; 593} 594 595/* 596 *---------------------------------------------------------------------- 597 * 598 * InfoBodyCmd -- 599 * 600 * Called to implement the "info body" command that returns the body 601 * for a procedure. Handles the following syntax: 602 * 603 * info body procName 604 * 605 * Results: 606 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 607 * 608 * Side effects: 609 * Returns a result in the interpreter's result object. If there is 610 * an error, the result is an error message. 611 * 612 *---------------------------------------------------------------------- 613 */ 614 615static int 616InfoBodyCmd(dummy, interp, objc, objv) 617 ClientData dummy; /* Not used. */ 618 Tcl_Interp *interp; /* Current interpreter. */ 619 int objc; /* Number of arguments. */ 620 Tcl_Obj *CONST objv[]; /* Argument objects. */ 621{ 622 register Interp *iPtr = (Interp *) interp; 623 char *name; 624 Proc *procPtr; 625 Tcl_Obj *bodyPtr, *resultPtr; 626 627 if (objc != 3) { 628 Tcl_WrongNumArgs(interp, 2, objv, "procname"); 629 return TCL_ERROR; 630 } 631 632 name = Tcl_GetString(objv[2]); 633 procPtr = TclFindProc(iPtr, name); 634 if (procPtr == NULL) { 635 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 636 "\"", name, "\" isn't a procedure", (char *) NULL); 637 return TCL_ERROR; 638 } 639 640 /* 641 * Here we used to return procPtr->bodyPtr, except when the body was 642 * bytecompiled - in that case, the return was a copy of the body's 643 * string rep. In order to better isolate the implementation details 644 * of the compiler/engine subsystem, we now always return a copy of 645 * the string rep. It is important to return a copy so that later 646 * manipulations of the object do not invalidate the internal rep. 647 */ 648 649 bodyPtr = procPtr->bodyPtr; 650 if (bodyPtr->bytes == NULL) { 651 /* 652 * The string rep might not be valid if the procedure has 653 * never been run before. [Bug #545644] 654 */ 655 (void) Tcl_GetString(bodyPtr); 656 } 657 resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); 658 659 Tcl_SetObjResult(interp, resultPtr); 660 return TCL_OK; 661} 662 663/* 664 *---------------------------------------------------------------------- 665 * 666 * InfoCmdCountCmd -- 667 * 668 * Called to implement the "info cmdcount" command that returns the 669 * number of commands that have been executed. Handles the following 670 * syntax: 671 * 672 * info cmdcount 673 * 674 * Results: 675 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 676 * 677 * Side effects: 678 * Returns a result in the interpreter's result object. If there is 679 * an error, the result is an error message. 680 * 681 *---------------------------------------------------------------------- 682 */ 683 684static int 685InfoCmdCountCmd(dummy, interp, objc, objv) 686 ClientData dummy; /* Not used. */ 687 Tcl_Interp *interp; /* Current interpreter. */ 688 int objc; /* Number of arguments. */ 689 Tcl_Obj *CONST objv[]; /* Argument objects. */ 690{ 691 Interp *iPtr = (Interp *) interp; 692 693 if (objc != 2) { 694 Tcl_WrongNumArgs(interp, 2, objv, NULL); 695 return TCL_ERROR; 696 } 697 698 Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount); 699 return TCL_OK; 700} 701 702/* 703 *---------------------------------------------------------------------- 704 * 705 * InfoCommandsCmd -- 706 * 707 * Called to implement the "info commands" command that returns the 708 * list of commands in the interpreter that match an optional pattern. 709 * The pattern, if any, consists of an optional sequence of namespace 710 * names separated by "::" qualifiers, which is followed by a 711 * glob-style pattern that restricts which commands are returned. 712 * Handles the following syntax: 713 * 714 * info commands ?pattern? 715 * 716 * Results: 717 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 718 * 719 * Side effects: 720 * Returns a result in the interpreter's result object. If there is 721 * an error, the result is an error message. 722 * 723 *---------------------------------------------------------------------- 724 */ 725 726static int 727InfoCommandsCmd(dummy, interp, objc, objv) 728 ClientData dummy; /* Not used. */ 729 Tcl_Interp *interp; /* Current interpreter. */ 730 int objc; /* Number of arguments. */ 731 Tcl_Obj *CONST objv[]; /* Argument objects. */ 732{ 733 char *cmdName, *pattern; 734 CONST char *simplePattern; 735 register Tcl_HashEntry *entryPtr; 736 Tcl_HashSearch search; 737 Namespace *nsPtr; 738 Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); 739 Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 740 Tcl_Obj *listPtr, *elemObjPtr; 741 int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ 742 Tcl_Command cmd; 743 744 /* 745 * Get the pattern and find the "effective namespace" in which to 746 * list commands. 747 */ 748 749 if (objc == 2) { 750 simplePattern = NULL; 751 nsPtr = currNsPtr; 752 specificNsInPattern = 0; 753 } else if (objc == 3) { 754 /* 755 * From the pattern, get the effective namespace and the simple 756 * pattern (no namespace qualifiers or ::'s) at the end. If an 757 * error was found while parsing the pattern, return it. Otherwise, 758 * if the namespace wasn't found, just leave nsPtr NULL: we will 759 * return an empty list since no commands there can be found. 760 */ 761 762 Namespace *dummy1NsPtr, *dummy2NsPtr; 763 764 765 pattern = Tcl_GetString(objv[2]); 766 TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 767 /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); 768 769 if (nsPtr != NULL) { /* we successfully found the pattern's ns */ 770 specificNsInPattern = (strcmp(simplePattern, pattern) != 0); 771 } 772 } else { 773 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); 774 return TCL_ERROR; 775 } 776 777 /* 778 * Exit as quickly as possible if we couldn't find the namespace. 779 */ 780 781 if (nsPtr == NULL) { 782 return TCL_OK; 783 } 784 785 /* 786 * Scan through the effective namespace's command table and create a 787 * list with all commands that match the pattern. If a specific 788 * namespace was requested in the pattern, qualify the command names 789 * with the namespace name. 790 */ 791 792 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 793 794 if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { 795 /* 796 * Special case for when the pattern doesn't include any of 797 * glob's special characters. This lets us avoid scans of any 798 * hash tables. 799 */ 800 entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); 801 if (entryPtr != NULL) { 802 if (specificNsInPattern) { 803 cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); 804 elemObjPtr = Tcl_NewObj(); 805 Tcl_GetCommandFullName(interp, cmd, elemObjPtr); 806 } else { 807 cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); 808 elemObjPtr = Tcl_NewStringObj(cmdName, -1); 809 } 810 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 811 } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { 812 entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable, 813 simplePattern); 814 if (entryPtr != NULL) { 815 cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); 816 Tcl_ListObjAppendElement(interp, listPtr, 817 Tcl_NewStringObj(cmdName, -1)); 818 } 819 } 820 } else { 821 entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); 822 while (entryPtr != NULL) { 823 cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); 824 if ((simplePattern == NULL) 825 || Tcl_StringMatch(cmdName, simplePattern)) { 826 if (specificNsInPattern) { 827 cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); 828 elemObjPtr = Tcl_NewObj(); 829 Tcl_GetCommandFullName(interp, cmd, elemObjPtr); 830 } else { 831 elemObjPtr = Tcl_NewStringObj(cmdName, -1); 832 } 833 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 834 } 835 entryPtr = Tcl_NextHashEntry(&search); 836 } 837 838 /* 839 * If the effective namespace isn't the global :: namespace, and a 840 * specific namespace wasn't requested in the pattern, then add in 841 * all global :: commands that match the simple pattern. Of course, 842 * we add in only those commands that aren't hidden by a command in 843 * the effective namespace. 844 */ 845 846 if ((nsPtr != globalNsPtr) && !specificNsInPattern) { 847 entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); 848 while (entryPtr != NULL) { 849 cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); 850 if ((simplePattern == NULL) 851 || Tcl_StringMatch(cmdName, simplePattern)) { 852 if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { 853 Tcl_ListObjAppendElement(interp, listPtr, 854 Tcl_NewStringObj(cmdName, -1)); 855 } 856 } 857 entryPtr = Tcl_NextHashEntry(&search); 858 } 859 } 860 } 861 862 Tcl_SetObjResult(interp, listPtr); 863 return TCL_OK; 864} 865 866/* 867 *---------------------------------------------------------------------- 868 * 869 * InfoCompleteCmd -- 870 * 871 * Called to implement the "info complete" command that determines 872 * whether a string is a complete Tcl command. Handles the following 873 * syntax: 874 * 875 * info complete command 876 * 877 * Results: 878 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 879 * 880 * Side effects: 881 * Returns a result in the interpreter's result object. If there is 882 * an error, the result is an error message. 883 * 884 *---------------------------------------------------------------------- 885 */ 886 887static int 888InfoCompleteCmd(dummy, interp, objc, objv) 889 ClientData dummy; /* Not used. */ 890 Tcl_Interp *interp; /* Current interpreter. */ 891 int objc; /* Number of arguments. */ 892 Tcl_Obj *CONST objv[]; /* Argument objects. */ 893{ 894 if (objc != 3) { 895 Tcl_WrongNumArgs(interp, 2, objv, "command"); 896 return TCL_ERROR; 897 } 898 899 if (TclObjCommandComplete(objv[2])) { 900 Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); 901 } else { 902 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); 903 } 904 905 return TCL_OK; 906} 907 908/* 909 *---------------------------------------------------------------------- 910 * 911 * InfoDefaultCmd -- 912 * 913 * Called to implement the "info default" command that returns the 914 * default value for a procedure argument. Handles the following 915 * syntax: 916 * 917 * info default procName arg varName 918 * 919 * Results: 920 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 921 * 922 * Side effects: 923 * Returns a result in the interpreter's result object. If there is 924 * an error, the result is an error message. 925 * 926 *---------------------------------------------------------------------- 927 */ 928 929static int 930InfoDefaultCmd(dummy, interp, objc, objv) 931 ClientData dummy; /* Not used. */ 932 Tcl_Interp *interp; /* Current interpreter. */ 933 int objc; /* Number of arguments. */ 934 Tcl_Obj *CONST objv[]; /* Argument objects. */ 935{ 936 Interp *iPtr = (Interp *) interp; 937 char *procName, *argName, *varName; 938 Proc *procPtr; 939 CompiledLocal *localPtr; 940 Tcl_Obj *valueObjPtr; 941 942 if (objc != 5) { 943 Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname"); 944 return TCL_ERROR; 945 } 946 947 procName = Tcl_GetString(objv[2]); 948 argName = Tcl_GetString(objv[3]); 949 950 procPtr = TclFindProc(iPtr, procName); 951 if (procPtr == NULL) { 952 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 953 "\"", procName, "\" isn't a procedure", (char *) NULL); 954 return TCL_ERROR; 955 } 956 957 for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; 958 localPtr = localPtr->nextPtr) { 959 if (TclIsVarArgument(localPtr) 960 && (strcmp(argName, localPtr->name) == 0)) { 961 if (localPtr->defValuePtr != NULL) { 962 valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, 963 localPtr->defValuePtr, 0); 964 if (valueObjPtr == NULL) { 965 defStoreError: 966 varName = Tcl_GetString(objv[4]); 967 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 968 "couldn't store default value in variable \"", 969 varName, "\"", (char *) NULL); 970 return TCL_ERROR; 971 } 972 Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); 973 } else { 974 Tcl_Obj *nullObjPtr = Tcl_NewObj(); 975 Tcl_IncrRefCount(nullObjPtr); 976 valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, 977 nullObjPtr, 0); 978 Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ 979 if (valueObjPtr == NULL) { 980 goto defStoreError; 981 } 982 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); 983 } 984 return TCL_OK; 985 } 986 } 987 988 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 989 "procedure \"", procName, "\" doesn't have an argument \"", 990 argName, "\"", (char *) NULL); 991 return TCL_ERROR; 992} 993 994/* 995 *---------------------------------------------------------------------- 996 * 997 * InfoExistsCmd -- 998 * 999 * Called to implement the "info exists" command that determines 1000 * whether a variable exists. Handles the following syntax: 1001 * 1002 * info exists varName 1003 * 1004 * Results: 1005 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1006 * 1007 * Side effects: 1008 * Returns a result in the interpreter's result object. If there is 1009 * an error, the result is an error message. 1010 * 1011 *---------------------------------------------------------------------- 1012 */ 1013 1014static int 1015InfoExistsCmd(dummy, interp, objc, objv) 1016 ClientData dummy; /* Not used. */ 1017 Tcl_Interp *interp; /* Current interpreter. */ 1018 int objc; /* Number of arguments. */ 1019 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1020{ 1021 char *varName; 1022 Var *varPtr; 1023 1024 if (objc != 3) { 1025 Tcl_WrongNumArgs(interp, 2, objv, "varName"); 1026 return TCL_ERROR; 1027 } 1028 1029 varName = Tcl_GetString(objv[2]); 1030 varPtr = TclVarTraceExists(interp, varName); 1031 if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) { 1032 Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); 1033 } else { 1034 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); 1035 } 1036 return TCL_OK; 1037} 1038 1039#ifdef TCL_TIP280 1040/* 1041 *---------------------------------------------------------------------- 1042 * 1043 * InfoFrameCmd -- 1044 * TIP #280 1045 * 1046 * Called to implement the "info frame" command that returns the 1047 * location of either the currently executing command, or its caller. 1048 * Handles the following syntax: 1049 * 1050 * info frame ?number? 1051 * 1052 * Results: 1053 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1054 * 1055 * Side effects: 1056 * Returns a result in the interpreter's result object. If there is 1057 * an error, the result is an error message. 1058 * 1059 *---------------------------------------------------------------------- 1060 */ 1061 1062static int 1063InfoFrameCmd(dummy, interp, objc, objv) 1064 ClientData dummy; /* Not used. */ 1065 Tcl_Interp *interp; /* Current interpreter. */ 1066 int objc; /* Number of arguments. */ 1067 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1068{ 1069 Interp *iPtr = (Interp *) interp; 1070 1071 if (objc == 2) { 1072 /* just "info frame" */ 1073 int levels = (iPtr->cmdFramePtr == NULL 1074 ? 0 1075 : iPtr->cmdFramePtr->level); 1076 1077 Tcl_SetObjResult(interp, Tcl_NewIntObj (levels)); 1078 return TCL_OK; 1079 1080 } else if (objc == 3) { 1081 /* "info frame level" */ 1082 int level; 1083 CmdFrame *framePtr; 1084 1085 if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { 1086 return TCL_ERROR; 1087 } 1088 if (level <= 0) { 1089 /* Relative adressing */ 1090 1091 if (iPtr->cmdFramePtr == NULL) { 1092 levelError: 1093 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1094 "bad level \"", 1095 Tcl_GetString(objv[2]), 1096 "\"", (char *) NULL); 1097 return TCL_ERROR; 1098 } 1099 /* Convert to absolute. */ 1100 1101 level += iPtr->cmdFramePtr->level; 1102 } 1103 for (framePtr = iPtr->cmdFramePtr; 1104 framePtr != NULL; 1105 framePtr = framePtr->nextPtr) { 1106 1107 if (framePtr->level == level) { 1108 break; 1109 } 1110 } 1111 if (framePtr == NULL) { 1112 goto levelError; 1113 } 1114 1115 /* 1116 * Pull the information and construct the dictionary to return, as 1117 * list. Regarding use of the CmdFrame fields see tclInt.h, and its 1118 * definition. 1119 */ 1120 1121 { 1122 Tcl_Obj* lv [20]; /* Keep uptodate when more keys are added to the dict */ 1123 int lc = 0; 1124 1125 /* This array is indexed by the TCL_LOCATION_... values, except 1126 * for _LAST. 1127 */ 1128 1129 static CONST char* typeString [TCL_LOCATION_LAST] = { 1130 "eval", "eval", "eval", "precompiled", "source", "proc" 1131 }; 1132 1133 Proc* procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; 1134 1135 switch (framePtr->type) { 1136 case TCL_LOCATION_EVAL: 1137 /* Evaluation, dynamic script. Type, line, cmd, the latter 1138 * through str. */ 1139 1140 lv [lc ++] = Tcl_NewStringObj ("type",-1); 1141 lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); 1142 lv [lc ++] = Tcl_NewStringObj ("line",-1); 1143 lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]); 1144 lv [lc ++] = Tcl_NewStringObj ("cmd",-1); 1145 lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd, 1146 framePtr->cmd.str.len); 1147 break; 1148 1149 case TCL_LOCATION_EVAL_LIST: 1150 /* List optimized evaluation. Type, line, cmd, the latter 1151 * through listPtr, possibly a frame. */ 1152 1153 lv [lc ++] = Tcl_NewStringObj ("type",-1); 1154 lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); 1155 lv [lc ++] = Tcl_NewStringObj ("line",-1); 1156 lv [lc ++] = Tcl_NewIntObj (1); 1157 1158 /* We put a duplicate of the command list obj into the result 1159 * to ensure that the 'pure List'-property of the command 1160 * itself is not destroyed. Otherwise the query here would 1161 * disable the list optimization path in Tcl_EvalObjEx. 1162 */ 1163 1164 lv [lc ++] = Tcl_NewStringObj ("cmd",-1); 1165 lv [lc ++] = Tcl_DuplicateObj (framePtr->cmd.listPtr); 1166 break; 1167 1168 case TCL_LOCATION_PREBC: 1169 /* Precompiled. Result contains the type as signal, nothing 1170 * else */ 1171 1172 lv [lc ++] = Tcl_NewStringObj ("type",-1); 1173 lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); 1174 break; 1175 1176 case TCL_LOCATION_BC: { 1177 /* Execution of bytecode. Talk to the BC engine to fill out 1178 * the frame. */ 1179 1180 CmdFrame f = *framePtr; 1181 1182 /* Note: Type BC => f.data.eval.path is not used. 1183 * f.data.tebc.codePtr is used instead. 1184 */ 1185 1186 TclGetSrcInfoForPc (&f); 1187 /* Now filled: cmd.str.(cmd,len), line */ 1188 /* Possibly modified: type, path! */ 1189 1190 lv [lc ++] = Tcl_NewStringObj ("type",-1); 1191 lv [lc ++] = Tcl_NewStringObj (typeString [f.type],-1); 1192 lv [lc ++] = Tcl_NewStringObj ("line",-1); 1193 lv [lc ++] = Tcl_NewIntObj (f.line[0]); 1194 1195 if (f.type == TCL_LOCATION_SOURCE) { 1196 lv [lc ++] = Tcl_NewStringObj ("file",-1); 1197 lv [lc ++] = f.data.eval.path; 1198 /* Death of reference by TclGetSrcInfoForPc */ 1199 Tcl_DecrRefCount (f.data.eval.path); 1200 } 1201 1202 lv [lc ++] = Tcl_NewStringObj ("cmd",-1); 1203 lv [lc ++] = Tcl_NewStringObj (f.cmd.str.cmd, f.cmd.str.len); 1204 break; 1205 } 1206 1207 case TCL_LOCATION_SOURCE: 1208 /* Evaluation of a script file */ 1209 1210 lv [lc ++] = Tcl_NewStringObj ("type",-1); 1211 lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); 1212 lv [lc ++] = Tcl_NewStringObj ("line",-1); 1213 lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]); 1214 lv [lc ++] = Tcl_NewStringObj ("file",-1); 1215 lv [lc ++] = framePtr->data.eval.path; 1216 /* Refcount framePtr->data.eval.path goes up when lv 1217 * is converted into the result list object. 1218 */ 1219 lv [lc ++] = Tcl_NewStringObj ("cmd",-1); 1220 lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd, 1221 framePtr->cmd.str.len); 1222 break; 1223 1224 case TCL_LOCATION_PROC: 1225 Tcl_Panic ("TCL_LOCATION_PROC found in standard frame"); 1226 break; 1227 } 1228 1229 /* 1230 * 'proc'. Common to all frame types. Conditional on having an 1231 * associated Procedure CallFrame. 1232 */ 1233 1234 if (procPtr != NULL) { 1235 Tcl_HashEntry* namePtr = procPtr->cmdPtr->hPtr; 1236 /* 1237 * ITcl seems to provide us with weird, maybe bogus Command 1238 * structures (methods?) which may have no HashEntry pointing 1239 * to the name information, or a HashEntry without owning 1240 * HashTable. Therefore check again that our data is valid. 1241 */ 1242 if (namePtr && namePtr->tablePtr) { 1243 char* procName = Tcl_GetHashKey (namePtr->tablePtr, namePtr); 1244 char* nsName = procPtr->cmdPtr->nsPtr->fullName; 1245 1246 lv [lc ++] = Tcl_NewStringObj ("proc",-1); 1247 lv [lc ++] = Tcl_NewStringObj (nsName,-1); 1248 1249 if (strcmp (nsName, "::") != 0) { 1250 Tcl_AppendToObj (lv [lc-1], "::", -1); 1251 } 1252 Tcl_AppendToObj (lv [lc-1], procName, -1); 1253 } 1254 } 1255 1256 /* 'level'. Common to all frame types. Conditional on having an 1257 * associated _visible_ CallFrame */ 1258 1259 if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) { 1260 CallFrame* current = framePtr->framePtr; 1261 CallFrame* top = iPtr->varFramePtr; 1262 CallFrame* idx; 1263 1264 for (idx = top; 1265 idx != NULL; 1266 idx = idx->callerVarPtr) { 1267 if (idx == current) { 1268 int c = framePtr->framePtr->level; 1269 int t = iPtr->varFramePtr->level; 1270 1271 lv [lc ++] = Tcl_NewStringObj ("level",-1); 1272 lv [lc ++] = Tcl_NewIntObj (t - c); 1273 break; 1274 } 1275 } 1276 } 1277 1278 Tcl_SetObjResult(interp, Tcl_NewListObj (lc, lv)); 1279 return TCL_OK; 1280 } 1281 } 1282 1283 Tcl_WrongNumArgs(interp, 2, objv, "?number?"); 1284 1285 return TCL_ERROR; 1286} 1287#endif 1288 1289/* 1290 *---------------------------------------------------------------------- 1291 * 1292 * InfoFunctionsCmd -- 1293 * 1294 * Called to implement the "info functions" command that returns the 1295 * list of math functions matching an optional pattern. Handles the 1296 * following syntax: 1297 * 1298 * info functions ?pattern? 1299 * 1300 * Results: 1301 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1302 * 1303 * Side effects: 1304 * Returns a result in the interpreter's result object. If there is 1305 * an error, the result is an error message. 1306 * 1307 *---------------------------------------------------------------------- 1308 */ 1309 1310static int 1311InfoFunctionsCmd(dummy, interp, objc, objv) 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 char *pattern; 1318 Tcl_Obj *listPtr; 1319 1320 if (objc == 2) { 1321 pattern = NULL; 1322 } else if (objc == 3) { 1323 pattern = Tcl_GetString(objv[2]); 1324 } else { 1325 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); 1326 return TCL_ERROR; 1327 } 1328 1329 listPtr = Tcl_ListMathFuncs(interp, pattern); 1330 if (listPtr == NULL) { 1331 return TCL_ERROR; 1332 } 1333 Tcl_SetObjResult(interp, listPtr); 1334 return TCL_OK; 1335} 1336 1337/* 1338 *---------------------------------------------------------------------- 1339 * 1340 * InfoGlobalsCmd -- 1341 * 1342 * Called to implement the "info globals" command that returns the list 1343 * of global variables matching an optional pattern. Handles the 1344 * following syntax: 1345 * 1346 * info globals ?pattern? 1347 * 1348 * Results: 1349 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1350 * 1351 * Side effects: 1352 * Returns a result in the interpreter's result object. If there is 1353 * an error, the result is an error message. 1354 * 1355 *---------------------------------------------------------------------- 1356 */ 1357 1358static int 1359InfoGlobalsCmd(dummy, interp, objc, objv) 1360 ClientData dummy; /* Not used. */ 1361 Tcl_Interp *interp; /* Current interpreter. */ 1362 int objc; /* Number of arguments. */ 1363 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1364{ 1365 char *varName, *pattern; 1366 Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); 1367 register Tcl_HashEntry *entryPtr; 1368 Tcl_HashSearch search; 1369 Var *varPtr; 1370 Tcl_Obj *listPtr; 1371 1372 if (objc == 2) { 1373 pattern = NULL; 1374 } else if (objc == 3) { 1375 pattern = Tcl_GetString(objv[2]); 1376 /* 1377 * Strip leading global-namespace qualifiers. [Bug 1057461] 1378 */ 1379 if (pattern[0] == ':' && pattern[1] == ':') { 1380 while (*pattern == ':') { 1381 pattern++; 1382 } 1383 } 1384 } else { 1385 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); 1386 return TCL_ERROR; 1387 } 1388 1389 /* 1390 * Scan through the global :: namespace's variable table and create a 1391 * list of all global variables that match the pattern. 1392 */ 1393 1394 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 1395 if (pattern != NULL && TclMatchIsTrivial(pattern)) { 1396 entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern); 1397 if (entryPtr != NULL) { 1398 varPtr = (Var *) Tcl_GetHashValue(entryPtr); 1399 if (!TclIsVarUndefined(varPtr)) { 1400 Tcl_ListObjAppendElement(interp, listPtr, 1401 Tcl_NewStringObj(pattern, -1)); 1402 } 1403 } 1404 } else { 1405 for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); 1406 entryPtr != NULL; 1407 entryPtr = Tcl_NextHashEntry(&search)) { 1408 varPtr = (Var *) Tcl_GetHashValue(entryPtr); 1409 if (TclIsVarUndefined(varPtr)) { 1410 continue; 1411 } 1412 varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr); 1413 if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { 1414 Tcl_ListObjAppendElement(interp, listPtr, 1415 Tcl_NewStringObj(varName, -1)); 1416 } 1417 } 1418 } 1419 Tcl_SetObjResult(interp, listPtr); 1420 return TCL_OK; 1421} 1422 1423/* 1424 *---------------------------------------------------------------------- 1425 * 1426 * InfoHostnameCmd -- 1427 * 1428 * Called to implement the "info hostname" command that returns the 1429 * host name. Handles the following syntax: 1430 * 1431 * info hostname 1432 * 1433 * Results: 1434 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1435 * 1436 * Side effects: 1437 * Returns a result in the interpreter's result object. If there is 1438 * an error, the result is an error message. 1439 * 1440 *---------------------------------------------------------------------- 1441 */ 1442 1443static int 1444InfoHostnameCmd(dummy, interp, objc, objv) 1445 ClientData dummy; /* Not used. */ 1446 Tcl_Interp *interp; /* Current interpreter. */ 1447 int objc; /* Number of arguments. */ 1448 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1449{ 1450 CONST char *name; 1451 if (objc != 2) { 1452 Tcl_WrongNumArgs(interp, 2, objv, NULL); 1453 return TCL_ERROR; 1454 } 1455 1456 name = Tcl_GetHostName(); 1457 if (name) { 1458 Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1); 1459 return TCL_OK; 1460 } else { 1461 Tcl_SetStringObj(Tcl_GetObjResult(interp), 1462 "unable to determine name of host", -1); 1463 return TCL_ERROR; 1464 } 1465} 1466 1467/* 1468 *---------------------------------------------------------------------- 1469 * 1470 * InfoLevelCmd -- 1471 * 1472 * Called to implement the "info level" command that returns 1473 * information about the call stack. Handles the following syntax: 1474 * 1475 * info level ?number? 1476 * 1477 * Results: 1478 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1479 * 1480 * Side effects: 1481 * Returns a result in the interpreter's result object. If there is 1482 * an error, the result is an error message. 1483 * 1484 *---------------------------------------------------------------------- 1485 */ 1486 1487static int 1488InfoLevelCmd(dummy, interp, objc, objv) 1489 ClientData dummy; /* Not used. */ 1490 Tcl_Interp *interp; /* Current interpreter. */ 1491 int objc; /* Number of arguments. */ 1492 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1493{ 1494 Interp *iPtr = (Interp *) interp; 1495 int level; 1496 CallFrame *framePtr; 1497 Tcl_Obj *listPtr; 1498 1499 if (objc == 2) { /* just "info level" */ 1500 if (iPtr->varFramePtr == NULL) { 1501 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); 1502 } else { 1503 Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level); 1504 } 1505 return TCL_OK; 1506 } else if (objc == 3) { 1507 if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { 1508 return TCL_ERROR; 1509 } 1510 if (level <= 0) { 1511 if (iPtr->varFramePtr == NULL) { 1512 levelError: 1513 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1514 "bad level \"", 1515 Tcl_GetString(objv[2]), 1516 "\"", (char *) NULL); 1517 return TCL_ERROR; 1518 } 1519 level += iPtr->varFramePtr->level; 1520 } 1521 for (framePtr = iPtr->varFramePtr; framePtr != NULL; 1522 framePtr = framePtr->callerVarPtr) { 1523 if (framePtr->level == level) { 1524 break; 1525 } 1526 } 1527 if (framePtr == NULL) { 1528 goto levelError; 1529 } 1530 1531 listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); 1532 Tcl_SetObjResult(interp, listPtr); 1533 return TCL_OK; 1534 } 1535 1536 Tcl_WrongNumArgs(interp, 2, objv, "?number?"); 1537 return TCL_ERROR; 1538} 1539 1540/* 1541 *---------------------------------------------------------------------- 1542 * 1543 * InfoLibraryCmd -- 1544 * 1545 * Called to implement the "info library" command that returns the 1546 * library directory for the Tcl installation. Handles the following 1547 * syntax: 1548 * 1549 * info library 1550 * 1551 * Results: 1552 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1553 * 1554 * Side effects: 1555 * Returns a result in the interpreter's result object. If there is 1556 * an error, the result is an error message. 1557 * 1558 *---------------------------------------------------------------------- 1559 */ 1560 1561static int 1562InfoLibraryCmd(dummy, interp, objc, objv) 1563 ClientData dummy; /* Not used. */ 1564 Tcl_Interp *interp; /* Current interpreter. */ 1565 int objc; /* Number of arguments. */ 1566 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1567{ 1568 CONST char *libDirName; 1569 1570 if (objc != 2) { 1571 Tcl_WrongNumArgs(interp, 2, objv, NULL); 1572 return TCL_ERROR; 1573 } 1574 1575 libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); 1576 if (libDirName != NULL) { 1577 Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1); 1578 return TCL_OK; 1579 } 1580 Tcl_SetStringObj(Tcl_GetObjResult(interp), 1581 "no library has been specified for Tcl", -1); 1582 return TCL_ERROR; 1583} 1584 1585/* 1586 *---------------------------------------------------------------------- 1587 * 1588 * InfoLoadedCmd -- 1589 * 1590 * Called to implement the "info loaded" command that returns the 1591 * packages that have been loaded into an interpreter. Handles the 1592 * following syntax: 1593 * 1594 * info loaded ?interp? 1595 * 1596 * Results: 1597 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1598 * 1599 * Side effects: 1600 * Returns a result in the interpreter's result object. If there is 1601 * an error, the result is an error message. 1602 * 1603 *---------------------------------------------------------------------- 1604 */ 1605 1606static int 1607InfoLoadedCmd(dummy, interp, objc, objv) 1608 ClientData dummy; /* Not used. */ 1609 Tcl_Interp *interp; /* Current interpreter. */ 1610 int objc; /* Number of arguments. */ 1611 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1612{ 1613 char *interpName; 1614 int result; 1615 1616 if ((objc != 2) && (objc != 3)) { 1617 Tcl_WrongNumArgs(interp, 2, objv, "?interp?"); 1618 return TCL_ERROR; 1619 } 1620 1621 if (objc == 2) { /* get loaded pkgs in all interpreters */ 1622 interpName = NULL; 1623 } else { /* get pkgs just in specified interp */ 1624 interpName = Tcl_GetString(objv[2]); 1625 } 1626 result = TclGetLoadedPackages(interp, interpName); 1627 return result; 1628} 1629 1630/* 1631 *---------------------------------------------------------------------- 1632 * 1633 * InfoLocalsCmd -- 1634 * 1635 * Called to implement the "info locals" command to return a list of 1636 * local variables that match an optional pattern. Handles the 1637 * following syntax: 1638 * 1639 * info locals ?pattern? 1640 * 1641 * Results: 1642 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1643 * 1644 * Side effects: 1645 * Returns a result in the interpreter's result object. If there is 1646 * an error, the result is an error message. 1647 * 1648 *---------------------------------------------------------------------- 1649 */ 1650 1651static int 1652InfoLocalsCmd(dummy, interp, objc, objv) 1653 ClientData dummy; /* Not used. */ 1654 Tcl_Interp *interp; /* Current interpreter. */ 1655 int objc; /* Number of arguments. */ 1656 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1657{ 1658 Interp *iPtr = (Interp *) interp; 1659 char *pattern; 1660 Tcl_Obj *listPtr; 1661 1662 if (objc == 2) { 1663 pattern = NULL; 1664 } else if (objc == 3) { 1665 pattern = Tcl_GetString(objv[2]); 1666 } else { 1667 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); 1668 return TCL_ERROR; 1669 } 1670 1671 if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) { 1672 return TCL_OK; 1673 } 1674 1675 /* 1676 * Return a list containing names of first the compiled locals (i.e. the 1677 * ones stored in the call frame), then the variables in the local hash 1678 * table (if one exists). 1679 */ 1680 1681 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 1682 AppendLocals(interp, listPtr, pattern, 0); 1683 Tcl_SetObjResult(interp, listPtr); 1684 return TCL_OK; 1685} 1686 1687/* 1688 *---------------------------------------------------------------------- 1689 * 1690 * AppendLocals -- 1691 * 1692 * Append the local variables for the current frame to the 1693 * specified list object. 1694 * 1695 * Results: 1696 * None. 1697 * 1698 * Side effects: 1699 * None. 1700 * 1701 *---------------------------------------------------------------------- 1702 */ 1703 1704static void 1705AppendLocals(interp, listPtr, pattern, includeLinks) 1706 Tcl_Interp *interp; /* Current interpreter. */ 1707 Tcl_Obj *listPtr; /* List object to append names to. */ 1708 CONST char *pattern; /* Pattern to match against. */ 1709 int includeLinks; /* 1 if upvars should be included, else 0. */ 1710{ 1711 Interp *iPtr = (Interp *) interp; 1712 CompiledLocal *localPtr; 1713 Var *varPtr; 1714 int i, localVarCt; 1715 char *varName; 1716 Tcl_HashTable *localVarTablePtr; 1717 register Tcl_HashEntry *entryPtr; 1718 Tcl_HashSearch search; 1719 1720 localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr; 1721 localVarCt = iPtr->varFramePtr->numCompiledLocals; 1722 varPtr = iPtr->varFramePtr->compiledLocals; 1723 localVarTablePtr = iPtr->varFramePtr->varTablePtr; 1724 1725 for (i = 0; i < localVarCt; i++) { 1726 /* 1727 * Skip nameless (temporary) variables and undefined variables 1728 */ 1729 1730 if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr) 1731 && (includeLinks || !TclIsVarLink(varPtr))) { 1732 varName = varPtr->name; 1733 if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { 1734 Tcl_ListObjAppendElement(interp, listPtr, 1735 Tcl_NewStringObj(varName, -1)); 1736 } 1737 } 1738 varPtr++; 1739 localPtr = localPtr->nextPtr; 1740 } 1741 1742 if (localVarTablePtr != NULL) { 1743 for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); 1744 entryPtr != NULL; 1745 entryPtr = Tcl_NextHashEntry(&search)) { 1746 varPtr = (Var *) Tcl_GetHashValue(entryPtr); 1747 if (!TclIsVarUndefined(varPtr) 1748 && (includeLinks || !TclIsVarLink(varPtr))) { 1749 varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); 1750 if ((pattern == NULL) 1751 || Tcl_StringMatch(varName, pattern)) { 1752 Tcl_ListObjAppendElement(interp, listPtr, 1753 Tcl_NewStringObj(varName, -1)); 1754 } 1755 } 1756 } 1757 } 1758} 1759 1760/* 1761 *---------------------------------------------------------------------- 1762 * 1763 * InfoNameOfExecutableCmd -- 1764 * 1765 * Called to implement the "info nameofexecutable" command that returns 1766 * the name of the binary file running this application. Handles the 1767 * following syntax: 1768 * 1769 * info nameofexecutable 1770 * 1771 * Results: 1772 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1773 * 1774 * Side effects: 1775 * Returns a result in the interpreter's result object. If there is 1776 * an error, the result is an error message. 1777 * 1778 *---------------------------------------------------------------------- 1779 */ 1780 1781static int 1782InfoNameOfExecutableCmd(dummy, interp, objc, objv) 1783 ClientData dummy; /* Not used. */ 1784 Tcl_Interp *interp; /* Current interpreter. */ 1785 int objc; /* Number of arguments. */ 1786 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1787{ 1788 CONST char *nameOfExecutable; 1789 1790 if (objc != 2) { 1791 Tcl_WrongNumArgs(interp, 2, objv, NULL); 1792 return TCL_ERROR; 1793 } 1794 1795 nameOfExecutable = Tcl_GetNameOfExecutable(); 1796 1797 if (nameOfExecutable != NULL) { 1798 Tcl_SetStringObj(Tcl_GetObjResult(interp), nameOfExecutable, -1); 1799 } 1800 return TCL_OK; 1801} 1802 1803/* 1804 *---------------------------------------------------------------------- 1805 * 1806 * InfoPatchLevelCmd -- 1807 * 1808 * Called to implement the "info patchlevel" command that returns the 1809 * default value for an argument to a procedure. Handles the following 1810 * syntax: 1811 * 1812 * info patchlevel 1813 * 1814 * Results: 1815 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1816 * 1817 * Side effects: 1818 * Returns a result in the interpreter's result object. If there is 1819 * an error, the result is an error message. 1820 * 1821 *---------------------------------------------------------------------- 1822 */ 1823 1824static int 1825InfoPatchLevelCmd(dummy, interp, objc, objv) 1826 ClientData dummy; /* Not used. */ 1827 Tcl_Interp *interp; /* Current interpreter. */ 1828 int objc; /* Number of arguments. */ 1829 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1830{ 1831 CONST char *patchlevel; 1832 1833 if (objc != 2) { 1834 Tcl_WrongNumArgs(interp, 2, objv, NULL); 1835 return TCL_ERROR; 1836 } 1837 1838 patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", 1839 (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); 1840 if (patchlevel != NULL) { 1841 Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1); 1842 return TCL_OK; 1843 } 1844 return TCL_ERROR; 1845} 1846 1847/* 1848 *---------------------------------------------------------------------- 1849 * 1850 * InfoProcsCmd -- 1851 * 1852 * Called to implement the "info procs" command that returns the 1853 * list of procedures in the interpreter that match an optional pattern. 1854 * The pattern, if any, consists of an optional sequence of namespace 1855 * names separated by "::" qualifiers, which is followed by a 1856 * glob-style pattern that restricts which commands are returned. 1857 * Handles the following syntax: 1858 * 1859 * info procs ?pattern? 1860 * 1861 * Results: 1862 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1863 * 1864 * Side effects: 1865 * Returns a result in the interpreter's result object. If there is 1866 * an error, the result is an error message. 1867 * 1868 *---------------------------------------------------------------------- 1869 */ 1870 1871static int 1872InfoProcsCmd(dummy, interp, objc, objv) 1873 ClientData dummy; /* Not used. */ 1874 Tcl_Interp *interp; /* Current interpreter. */ 1875 int objc; /* Number of arguments. */ 1876 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1877{ 1878 char *cmdName, *pattern; 1879 CONST char *simplePattern; 1880 Namespace *nsPtr; 1881#ifdef INFO_PROCS_SEARCH_GLOBAL_NS 1882 Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); 1883#endif 1884 Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 1885 Tcl_Obj *listPtr, *elemObjPtr; 1886 int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ 1887 register Tcl_HashEntry *entryPtr; 1888 Tcl_HashSearch search; 1889 Command *cmdPtr, *realCmdPtr; 1890 1891 /* 1892 * Get the pattern and find the "effective namespace" in which to 1893 * list procs. 1894 */ 1895 1896 if (objc == 2) { 1897 simplePattern = NULL; 1898 nsPtr = currNsPtr; 1899 specificNsInPattern = 0; 1900 } else if (objc == 3) { 1901 /* 1902 * From the pattern, get the effective namespace and the simple 1903 * pattern (no namespace qualifiers or ::'s) at the end. If an 1904 * error was found while parsing the pattern, return it. Otherwise, 1905 * if the namespace wasn't found, just leave nsPtr NULL: we will 1906 * return an empty list since no commands there can be found. 1907 */ 1908 1909 Namespace *dummy1NsPtr, *dummy2NsPtr; 1910 1911 pattern = Tcl_GetString(objv[2]); 1912 TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 1913 /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, 1914 &simplePattern); 1915 1916 if (nsPtr != NULL) { /* we successfully found the pattern's ns */ 1917 specificNsInPattern = (strcmp(simplePattern, pattern) != 0); 1918 } 1919 } else { 1920 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); 1921 return TCL_ERROR; 1922 } 1923 1924 if (nsPtr == NULL) { 1925 return TCL_OK; 1926 } 1927 1928 /* 1929 * Scan through the effective namespace's command table and create a 1930 * list with all procs that match the pattern. If a specific 1931 * namespace was requested in the pattern, qualify the command names 1932 * with the namespace name. 1933 */ 1934 1935 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 1936#ifndef INFO_PROCS_SEARCH_GLOBAL_NS 1937 if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { 1938 entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); 1939 if (entryPtr != NULL) { 1940 cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); 1941 1942 if (!TclIsProc(cmdPtr)) { 1943 realCmdPtr = (Command *) 1944 TclGetOriginalCommand((Tcl_Command) cmdPtr); 1945 if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { 1946 goto simpleProcOK; 1947 } 1948 } else { 1949 simpleProcOK: 1950 if (specificNsInPattern) { 1951 elemObjPtr = Tcl_NewObj(); 1952 Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, 1953 elemObjPtr); 1954 } else { 1955 elemObjPtr = Tcl_NewStringObj(simplePattern, -1); 1956 } 1957 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 1958 } 1959 } 1960 } else 1961#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */ 1962 { 1963 entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); 1964 while (entryPtr != NULL) { 1965 cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); 1966 if ((simplePattern == NULL) 1967 || Tcl_StringMatch(cmdName, simplePattern)) { 1968 cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); 1969 1970 if (!TclIsProc(cmdPtr)) { 1971 realCmdPtr = (Command *) 1972 TclGetOriginalCommand((Tcl_Command) cmdPtr); 1973 if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { 1974 goto procOK; 1975 } 1976 } else { 1977 procOK: 1978 if (specificNsInPattern) { 1979 elemObjPtr = Tcl_NewObj(); 1980 Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, 1981 elemObjPtr); 1982 } else { 1983 elemObjPtr = Tcl_NewStringObj(cmdName, -1); 1984 } 1985 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 1986 } 1987 } 1988 entryPtr = Tcl_NextHashEntry(&search); 1989 } 1990 1991 /* 1992 * If the effective namespace isn't the global :: namespace, and a 1993 * specific namespace wasn't requested in the pattern, then add in 1994 * all global :: procs that match the simple pattern. Of course, 1995 * we add in only those procs that aren't hidden by a proc in 1996 * the effective namespace. 1997 */ 1998 1999#ifdef INFO_PROCS_SEARCH_GLOBAL_NS 2000 /* 2001 * If "info procs" worked like "info commands", returning the 2002 * commands also seen in the global namespace, then you would 2003 * include this code. As this could break backwards compatibilty 2004 * with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the 2005 * behavior slightly different. 2006 */ 2007 if ((nsPtr != globalNsPtr) && !specificNsInPattern) { 2008 entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); 2009 while (entryPtr != NULL) { 2010 cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); 2011 if ((simplePattern == NULL) 2012 || Tcl_StringMatch(cmdName, simplePattern)) { 2013 if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { 2014 cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); 2015 realCmdPtr = (Command *) TclGetOriginalCommand( 2016 (Tcl_Command) cmdPtr); 2017 2018 if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL) 2019 && TclIsProc(realCmdPtr))) { 2020 Tcl_ListObjAppendElement(interp, listPtr, 2021 Tcl_NewStringObj(cmdName, -1)); 2022 } 2023 } 2024 } 2025 entryPtr = Tcl_NextHashEntry(&search); 2026 } 2027 } 2028#endif 2029 } 2030 2031 Tcl_SetObjResult(interp, listPtr); 2032 return TCL_OK; 2033} 2034 2035/* 2036 *---------------------------------------------------------------------- 2037 * 2038 * InfoScriptCmd -- 2039 * 2040 * Called to implement the "info script" command that returns the 2041 * script file that is currently being evaluated. Handles the 2042 * following syntax: 2043 * 2044 * info script ?newName? 2045 * 2046 * If newName is specified, it will set that as the internal name. 2047 * 2048 * Results: 2049 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 2050 * 2051 * Side effects: 2052 * Returns a result in the interpreter's result object. If there is 2053 * an error, the result is an error message. It may change the 2054 * internal script filename. 2055 * 2056 *---------------------------------------------------------------------- 2057 */ 2058 2059static int 2060InfoScriptCmd(dummy, interp, objc, objv) 2061 ClientData dummy; /* Not used. */ 2062 Tcl_Interp *interp; /* Current interpreter. */ 2063 int objc; /* Number of arguments. */ 2064 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2065{ 2066 Interp *iPtr = (Interp *) interp; 2067 if ((objc != 2) && (objc != 3)) { 2068 Tcl_WrongNumArgs(interp, 2, objv, "?filename?"); 2069 return TCL_ERROR; 2070 } 2071 2072 if (objc == 3) { 2073 if (iPtr->scriptFile != NULL) { 2074 Tcl_DecrRefCount(iPtr->scriptFile); 2075 } 2076 iPtr->scriptFile = objv[2]; 2077 Tcl_IncrRefCount(iPtr->scriptFile); 2078 } 2079 if (iPtr->scriptFile != NULL) { 2080 Tcl_SetObjResult(interp, iPtr->scriptFile); 2081 } 2082 return TCL_OK; 2083} 2084 2085/* 2086 *---------------------------------------------------------------------- 2087 * 2088 * InfoSharedlibCmd -- 2089 * 2090 * Called to implement the "info sharedlibextension" command that 2091 * returns the file extension used for shared libraries. Handles the 2092 * following syntax: 2093 * 2094 * info sharedlibextension 2095 * 2096 * Results: 2097 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 2098 * 2099 * Side effects: 2100 * Returns a result in the interpreter's result object. If there is 2101 * an error, the result is an error message. 2102 * 2103 *---------------------------------------------------------------------- 2104 */ 2105 2106static int 2107InfoSharedlibCmd(dummy, interp, objc, objv) 2108 ClientData dummy; /* Not used. */ 2109 Tcl_Interp *interp; /* Current interpreter. */ 2110 int objc; /* Number of arguments. */ 2111 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2112{ 2113 if (objc != 2) { 2114 Tcl_WrongNumArgs(interp, 2, objv, NULL); 2115 return TCL_ERROR; 2116 } 2117 2118#ifdef TCL_SHLIB_EXT 2119 Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1); 2120#endif 2121 return TCL_OK; 2122} 2123 2124/* 2125 *---------------------------------------------------------------------- 2126 * 2127 * InfoTclVersionCmd -- 2128 * 2129 * Called to implement the "info tclversion" command that returns the 2130 * version number for this Tcl library. Handles the following syntax: 2131 * 2132 * info tclversion 2133 * 2134 * Results: 2135 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 2136 * 2137 * Side effects: 2138 * Returns a result in the interpreter's result object. If there is 2139 * an error, the result is an error message. 2140 * 2141 *---------------------------------------------------------------------- 2142 */ 2143 2144static int 2145InfoTclVersionCmd(dummy, interp, objc, objv) 2146 ClientData dummy; /* Not used. */ 2147 Tcl_Interp *interp; /* Current interpreter. */ 2148 int objc; /* Number of arguments. */ 2149 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2150{ 2151 CONST char *version; 2152 2153 if (objc != 2) { 2154 Tcl_WrongNumArgs(interp, 2, objv, NULL); 2155 return TCL_ERROR; 2156 } 2157 2158 version = Tcl_GetVar(interp, "tcl_version", 2159 (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); 2160 if (version != NULL) { 2161 Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1); 2162 return TCL_OK; 2163 } 2164 return TCL_ERROR; 2165} 2166 2167/* 2168 *---------------------------------------------------------------------- 2169 * 2170 * InfoVarsCmd -- 2171 * 2172 * Called to implement the "info vars" command that returns the 2173 * list of variables in the interpreter that match an optional pattern. 2174 * The pattern, if any, consists of an optional sequence of namespace 2175 * names separated by "::" qualifiers, which is followed by a 2176 * glob-style pattern that restricts which variables are returned. 2177 * Handles the following syntax: 2178 * 2179 * info vars ?pattern? 2180 * 2181 * Results: 2182 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 2183 * 2184 * Side effects: 2185 * Returns a result in the interpreter's result object. If there is 2186 * an error, the result is an error message. 2187 * 2188 *---------------------------------------------------------------------- 2189 */ 2190 2191static int 2192InfoVarsCmd(dummy, interp, objc, objv) 2193 ClientData dummy; /* Not used. */ 2194 Tcl_Interp *interp; /* Current interpreter. */ 2195 int objc; /* Number of arguments. */ 2196 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2197{ 2198 Interp *iPtr = (Interp *) interp; 2199 char *varName, *pattern; 2200 CONST char *simplePattern; 2201 register Tcl_HashEntry *entryPtr; 2202 Tcl_HashSearch search; 2203 Var *varPtr; 2204 Namespace *nsPtr; 2205 Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); 2206 Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 2207 Tcl_Obj *listPtr, *elemObjPtr; 2208 int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ 2209 2210 /* 2211 * Get the pattern and find the "effective namespace" in which to 2212 * list variables. We only use this effective namespace if there's 2213 * no active Tcl procedure frame. 2214 */ 2215 2216 if (objc == 2) { 2217 simplePattern = NULL; 2218 nsPtr = currNsPtr; 2219 specificNsInPattern = 0; 2220 } else if (objc == 3) { 2221 /* 2222 * From the pattern, get the effective namespace and the simple 2223 * pattern (no namespace qualifiers or ::'s) at the end. If an 2224 * error was found while parsing the pattern, return it. Otherwise, 2225 * if the namespace wasn't found, just leave nsPtr NULL: we will 2226 * return an empty list since no variables there can be found. 2227 */ 2228 2229 Namespace *dummy1NsPtr, *dummy2NsPtr; 2230 2231 pattern = Tcl_GetString(objv[2]); 2232 TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 2233 /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, 2234 &simplePattern); 2235 2236 if (nsPtr != NULL) { /* we successfully found the pattern's ns */ 2237 specificNsInPattern = (strcmp(simplePattern, pattern) != 0); 2238 } 2239 } else { 2240 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); 2241 return TCL_ERROR; 2242 } 2243 2244 /* 2245 * If the namespace specified in the pattern wasn't found, just return. 2246 */ 2247 2248 if (nsPtr == NULL) { 2249 return TCL_OK; 2250 } 2251 2252 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 2253 2254 if ((iPtr->varFramePtr == NULL) 2255 || !iPtr->varFramePtr->isProcCallFrame 2256 || specificNsInPattern) { 2257 /* 2258 * There is no frame pointer, the frame pointer was pushed only 2259 * to activate a namespace, or we are in a procedure call frame 2260 * but a specific namespace was specified. Create a list containing 2261 * only the variables in the effective namespace's variable table. 2262 */ 2263 2264 if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { 2265 /* 2266 * If we can just do hash lookups, that simplifies things 2267 * a lot. 2268 */ 2269 2270 entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern); 2271 if (entryPtr != NULL) { 2272 varPtr = (Var *) Tcl_GetHashValue(entryPtr); 2273 if (!TclIsVarUndefined(varPtr) 2274 || (varPtr->flags & VAR_NAMESPACE_VAR)) { 2275 if (specificNsInPattern) { 2276 elemObjPtr = Tcl_NewObj(); 2277 Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, 2278 elemObjPtr); 2279 } else { 2280 elemObjPtr = Tcl_NewStringObj(simplePattern, -1); 2281 } 2282 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 2283 } 2284 } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { 2285 entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, 2286 simplePattern); 2287 if (entryPtr != NULL) { 2288 varPtr = (Var *) Tcl_GetHashValue(entryPtr); 2289 if (!TclIsVarUndefined(varPtr) 2290 || (varPtr->flags & VAR_NAMESPACE_VAR)) { 2291 Tcl_ListObjAppendElement(interp, listPtr, 2292 Tcl_NewStringObj(simplePattern, -1)); 2293 } 2294 } 2295 } 2296 } else { 2297 /* 2298 * Have to scan the tables of variables. 2299 */ 2300 2301 entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search); 2302 while (entryPtr != NULL) { 2303 varPtr = (Var *) Tcl_GetHashValue(entryPtr); 2304 if (!TclIsVarUndefined(varPtr) 2305 || (varPtr->flags & VAR_NAMESPACE_VAR)) { 2306 varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr); 2307 if ((simplePattern == NULL) 2308 || Tcl_StringMatch(varName, simplePattern)) { 2309 if (specificNsInPattern) { 2310 elemObjPtr = Tcl_NewObj(); 2311 Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, 2312 elemObjPtr); 2313 } else { 2314 elemObjPtr = Tcl_NewStringObj(varName, -1); 2315 } 2316 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 2317 } 2318 } 2319 entryPtr = Tcl_NextHashEntry(&search); 2320 } 2321 2322 /* 2323 * If the effective namespace isn't the global :: 2324 * namespace, and a specific namespace wasn't requested in 2325 * the pattern (i.e., the pattern only specifies variable 2326 * names), then add in all global :: variables that match 2327 * the simple pattern. Of course, add in only those 2328 * variables that aren't hidden by a variable in the 2329 * effective namespace. 2330 */ 2331 2332 if ((nsPtr != globalNsPtr) && !specificNsInPattern) { 2333 entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); 2334 while (entryPtr != NULL) { 2335 varPtr = (Var *) Tcl_GetHashValue(entryPtr); 2336 if (!TclIsVarUndefined(varPtr) 2337 || (varPtr->flags & VAR_NAMESPACE_VAR)) { 2338 varName = Tcl_GetHashKey(&globalNsPtr->varTable, 2339 entryPtr); 2340 if ((simplePattern == NULL) 2341 || Tcl_StringMatch(varName, simplePattern)) { 2342 if (Tcl_FindHashEntry(&nsPtr->varTable, 2343 varName) == NULL) { 2344 Tcl_ListObjAppendElement(interp, listPtr, 2345 Tcl_NewStringObj(varName, -1)); 2346 } 2347 } 2348 } 2349 entryPtr = Tcl_NextHashEntry(&search); 2350 } 2351 } 2352 } 2353 } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) { 2354 AppendLocals(interp, listPtr, simplePattern, 1); 2355 } 2356 2357 Tcl_SetObjResult(interp, listPtr); 2358 return TCL_OK; 2359} 2360 2361/* 2362 *---------------------------------------------------------------------- 2363 * 2364 * Tcl_JoinObjCmd -- 2365 * 2366 * This procedure is invoked to process the "join" Tcl command. 2367 * See the user documentation for details on what it does. 2368 * 2369 * Results: 2370 * A standard Tcl object result. 2371 * 2372 * Side effects: 2373 * See the user documentation. 2374 * 2375 *---------------------------------------------------------------------- 2376 */ 2377 2378 /* ARGSUSED */ 2379int 2380Tcl_JoinObjCmd(dummy, interp, objc, objv) 2381 ClientData dummy; /* Not used. */ 2382 Tcl_Interp *interp; /* Current interpreter. */ 2383 int objc; /* Number of arguments. */ 2384 Tcl_Obj *CONST objv[]; /* The argument objects. */ 2385{ 2386 char *joinString, *bytes; 2387 int joinLength, listLen, length, i, result; 2388 Tcl_Obj **elemPtrs; 2389 Tcl_Obj *resObjPtr; 2390 2391 if (objc == 2) { 2392 joinString = " "; 2393 joinLength = 1; 2394 } else if (objc == 3) { 2395 joinString = Tcl_GetStringFromObj(objv[2], &joinLength); 2396 } else { 2397 Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); 2398 return TCL_ERROR; 2399 } 2400 2401 /* 2402 * Make sure the list argument is a list object and get its length and 2403 * a pointer to its array of element pointers. 2404 */ 2405 2406 result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs); 2407 if (result != TCL_OK) { 2408 return result; 2409 } 2410 2411 /* 2412 * Now concatenate strings to form the "joined" result. We append 2413 * directly into the interpreter's result object. 2414 */ 2415 2416 resObjPtr = Tcl_GetObjResult(interp); 2417 2418 for (i = 0; i < listLen; i++) { 2419 bytes = Tcl_GetStringFromObj(elemPtrs[i], &length); 2420 if (i > 0) { 2421 Tcl_AppendToObj(resObjPtr, joinString, joinLength); 2422 } 2423 Tcl_AppendToObj(resObjPtr, bytes, length); 2424 } 2425 return TCL_OK; 2426} 2427 2428/* 2429 *---------------------------------------------------------------------- 2430 * 2431 * Tcl_LindexObjCmd -- 2432 * 2433 * This object-based procedure is invoked to process the "lindex" Tcl 2434 * command. See the user documentation for details on what it does. 2435 * 2436 * Results: 2437 * A standard Tcl object result. 2438 * 2439 * Side effects: 2440 * See the user documentation. 2441 * 2442 *---------------------------------------------------------------------- 2443 */ 2444 2445 /* ARGSUSED */ 2446int 2447Tcl_LindexObjCmd(dummy, interp, objc, objv) 2448 ClientData dummy; /* Not used. */ 2449 Tcl_Interp *interp; /* Current interpreter. */ 2450 int objc; /* Number of arguments. */ 2451 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2452{ 2453 2454 Tcl_Obj *elemPtr; /* Pointer to the element being extracted */ 2455 2456 if (objc < 2) { 2457 Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?"); 2458 return TCL_ERROR; 2459 } 2460 2461 /* 2462 * If objc == 3, then objv[ 2 ] may be either a single index or 2463 * a list of indices: go to TclLindexList to determine which. 2464 * If objc >= 4, or objc == 2, then objv[ 2 .. objc-2 ] are all 2465 * single indices and processed as such in TclLindexFlat. 2466 */ 2467 2468 if ( objc == 3 ) { 2469 2470 elemPtr = TclLindexList( interp, objv[ 1 ], objv[ 2 ] ); 2471 2472 } else { 2473 2474 elemPtr = TclLindexFlat( interp, objv[ 1 ], objc-2, objv+2 ); 2475 2476 } 2477 2478 /* 2479 * Set the interpreter's object result to the last element extracted 2480 */ 2481 2482 if ( elemPtr == NULL ) { 2483 return TCL_ERROR; 2484 } else { 2485 Tcl_SetObjResult(interp, elemPtr); 2486 Tcl_DecrRefCount( elemPtr ); 2487 return TCL_OK; 2488 } 2489} 2490 2491/* 2492 *---------------------------------------------------------------------- 2493 * 2494 * TclLindexList -- 2495 * 2496 * This procedure handles the 'lindex' command when objc==3. 2497 * 2498 * Results: 2499 * Returns a pointer to the object extracted, or NULL if an 2500 * error occurred. 2501 * 2502 * Side effects: 2503 * None. 2504 * 2505 * If objv[1] can be parsed as a list, TclLindexList handles extraction 2506 * of the desired element locally. Otherwise, it invokes 2507 * TclLindexFlat to treat objv[1] as a scalar. 2508 * 2509 * The reference count of the returned object includes one reference 2510 * corresponding to the pointer returned. Thus, the calling code will 2511 * usually do something like: 2512 * Tcl_SetObjResult( interp, result ); 2513 * Tcl_DecrRefCount( result ); 2514 * 2515 *---------------------------------------------------------------------- 2516 */ 2517 2518Tcl_Obj * 2519TclLindexList( interp, listPtr, argPtr ) 2520 Tcl_Interp* interp; /* Tcl interpreter */ 2521 Tcl_Obj* listPtr; /* List being unpacked */ 2522 Tcl_Obj* argPtr; /* Index or index list */ 2523{ 2524 2525 Tcl_Obj **elemPtrs; /* Elements of the list being manipulated. */ 2526 int listLen; /* Length of the list being manipulated. */ 2527 int index; /* Index into the list */ 2528 int result; /* Result returned from a Tcl library call */ 2529 int i; /* Current index number */ 2530 Tcl_Obj** indices; /* Array of list indices */ 2531 int indexCount; /* Size of the array of list indices */ 2532 Tcl_Obj* oldListPtr; /* Temp location to preserve the list 2533 * pointer when replacing it with a sublist */ 2534 2535 /* 2536 * Determine whether argPtr designates a list or a single index. 2537 * We have to be careful about the order of the checks to avoid 2538 * repeated shimmering; see TIP#22 and TIP#33 for the details. 2539 */ 2540 2541 if ( argPtr->typePtr != &tclListType 2542 && TclGetIntForIndex( NULL , argPtr, 0, &index ) == TCL_OK ) { 2543 2544 /* 2545 * argPtr designates a single index. 2546 */ 2547 2548 return TclLindexFlat( interp, listPtr, 1, &argPtr ); 2549 2550 } else if ( Tcl_ListObjGetElements( NULL, argPtr, &indexCount, &indices ) 2551 != TCL_OK ) { 2552 2553 /* 2554 * argPtr designates something that is neither an index nor a 2555 * well-formed list. Report the error via TclLindexFlat. 2556 */ 2557 2558 return TclLindexFlat( interp, listPtr, 1, &argPtr ); 2559 } 2560 2561 /* 2562 * Record the reference to the list that we are maintaining in 2563 * the activation record. 2564 */ 2565 2566 Tcl_IncrRefCount( listPtr ); 2567 2568 /* 2569 * argPtr designates a list, and the 'else if' above has parsed it 2570 * into indexCount and indices. 2571 */ 2572 2573 for ( i = 0; i < indexCount; ++i ) { 2574 2575 /* 2576 * Convert the current listPtr to a list if necessary. 2577 */ 2578 2579 result = Tcl_ListObjGetElements( interp, listPtr, 2580 &listLen, &elemPtrs); 2581 if (result != TCL_OK) { 2582 Tcl_DecrRefCount( listPtr ); 2583 return NULL; 2584 } 2585 2586 /* 2587 * Get the index from indices[ i ] 2588 */ 2589 2590 result = TclGetIntForIndex( interp, indices[ i ], 2591 /*endValue*/ (listLen - 1), 2592 &index ); 2593 if ( result != TCL_OK ) { 2594 /* 2595 * Index could not be parsed 2596 */ 2597 2598 Tcl_DecrRefCount( listPtr ); 2599 return NULL; 2600 2601 } else if ( index < 0 2602 || index >= listLen ) { 2603 /* 2604 * Index is out of range 2605 */ 2606 Tcl_DecrRefCount( listPtr ); 2607 listPtr = Tcl_NewObj(); 2608 Tcl_IncrRefCount( listPtr ); 2609 return listPtr; 2610 } 2611 2612 /* 2613 * Make sure listPtr still refers to a list object. 2614 * If it shared a Tcl_Obj structure with the arguments, then 2615 * it might have just been converted to something else. 2616 */ 2617 2618 if (listPtr->typePtr != &tclListType) { 2619 result = Tcl_ListObjGetElements(interp, listPtr, &listLen, 2620 &elemPtrs); 2621 if (result != TCL_OK) { 2622 Tcl_DecrRefCount( listPtr ); 2623 return NULL; 2624 } 2625 } 2626 2627 /* 2628 * Extract the pointer to the appropriate element 2629 */ 2630 2631 oldListPtr = listPtr; 2632 listPtr = elemPtrs[ index ]; 2633 Tcl_IncrRefCount( listPtr ); 2634 Tcl_DecrRefCount( oldListPtr ); 2635 2636 /* 2637 * The work we did above may have caused the internal rep 2638 * of *argPtr to change to something else. Get it back. 2639 */ 2640 2641 result = Tcl_ListObjGetElements( interp, argPtr, 2642 &indexCount, &indices ); 2643 if ( result != TCL_OK ) { 2644 /* 2645 * This can't happen unless some extension corrupted a Tcl_Obj. 2646 */ 2647 Tcl_DecrRefCount( listPtr ); 2648 return NULL; 2649 } 2650 2651 } /* end for */ 2652 2653 /* 2654 * Return the last object extracted. Its reference count will include 2655 * the reference being returned. 2656 */ 2657 2658 return listPtr; 2659} 2660 2661/* 2662 *---------------------------------------------------------------------- 2663 * 2664 * TclLindexFlat -- 2665 * 2666 * This procedure handles the 'lindex' command, given that the 2667 * arguments to the command are known to be a flat list. 2668 * 2669 * Results: 2670 * Returns a standard Tcl result. 2671 * 2672 * Side effects: 2673 * None. 2674 * 2675 * This procedure is called from either tclExecute.c or 2676 * Tcl_LindexObjCmd whenever either is presented with 2677 * objc == 2 or objc >= 4. It is also called from TclLindexList 2678 * for the objc==3 case once it is determined that objv[2] cannot 2679 * be parsed as a list. 2680 * 2681 *---------------------------------------------------------------------- 2682 */ 2683 2684Tcl_Obj * 2685TclLindexFlat( interp, listPtr, indexCount, indexArray ) 2686 Tcl_Interp* interp; /* Tcl interpreter */ 2687 Tcl_Obj* listPtr; /* Tcl object representing the list */ 2688 int indexCount; /* Count of indices */ 2689 Tcl_Obj* CONST indexArray[]; 2690 /* Array of pointers to Tcl objects 2691 * representing the indices in the 2692 * list */ 2693{ 2694 2695 int i; /* Current list index */ 2696 int result; /* Result of Tcl library calls */ 2697 int listLen; /* Length of the current list being 2698 * processed */ 2699 Tcl_Obj** elemPtrs; /* Array of pointers to the elements 2700 * of the current list */ 2701 int index; /* Parsed version of the current element 2702 * of indexArray */ 2703 Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that 2704 * its ref count can be decremented. */ 2705 2706 /* 2707 * Record the reference to the 'listPtr' object that we are 2708 * maintaining in the C activation record. 2709 */ 2710 2711 Tcl_IncrRefCount( listPtr ); 2712 2713 for ( i = 0; i < indexCount; ++i ) { 2714 2715 /* 2716 * Convert the current listPtr to a list if necessary. 2717 */ 2718 2719 result = Tcl_ListObjGetElements(interp, listPtr, 2720 &listLen, &elemPtrs); 2721 if (result != TCL_OK) { 2722 Tcl_DecrRefCount( listPtr ); 2723 return NULL; 2724 } 2725 2726 /* 2727 * Get the index from objv[i] 2728 */ 2729 2730 result = TclGetIntForIndex( interp, indexArray[ i ], 2731 /*endValue*/ (listLen - 1), 2732 &index ); 2733 if ( result != TCL_OK ) { 2734 2735 /* Index could not be parsed */ 2736 2737 Tcl_DecrRefCount( listPtr ); 2738 return NULL; 2739 2740 } else if ( index < 0 2741 || index >= listLen ) { 2742 2743 /* 2744 * Index is out of range 2745 */ 2746 2747 Tcl_DecrRefCount( listPtr ); 2748 listPtr = Tcl_NewObj(); 2749 Tcl_IncrRefCount( listPtr ); 2750 return listPtr; 2751 } 2752 2753 /* 2754 * Make sure listPtr still refers to a list object. 2755 * It might have been converted to something else above 2756 * if objv[1] overlaps with one of the other parameters. 2757 */ 2758 2759 if (listPtr->typePtr != &tclListType) { 2760 result = Tcl_ListObjGetElements(interp, listPtr, &listLen, 2761 &elemPtrs); 2762 if (result != TCL_OK) { 2763 Tcl_DecrRefCount( listPtr ); 2764 return NULL; 2765 } 2766 } 2767 2768 /* 2769 * Extract the pointer to the appropriate element 2770 */ 2771 2772 oldListPtr = listPtr; 2773 listPtr = elemPtrs[ index ]; 2774 Tcl_IncrRefCount( listPtr ); 2775 Tcl_DecrRefCount( oldListPtr ); 2776 2777 } 2778 2779 return listPtr; 2780 2781} 2782 2783/* 2784 *---------------------------------------------------------------------- 2785 * 2786 * Tcl_LinsertObjCmd -- 2787 * 2788 * This object-based procedure is invoked to process the "linsert" Tcl 2789 * command. See the user documentation for details on what it does. 2790 * 2791 * Results: 2792 * A new Tcl list object formed by inserting zero or more elements 2793 * into a list. 2794 * 2795 * Side effects: 2796 * See the user documentation. 2797 * 2798 *---------------------------------------------------------------------- 2799 */ 2800 2801 /* ARGSUSED */ 2802int 2803Tcl_LinsertObjCmd(dummy, interp, objc, objv) 2804 ClientData dummy; /* Not used. */ 2805 Tcl_Interp *interp; /* Current interpreter. */ 2806 register int objc; /* Number of arguments. */ 2807 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2808{ 2809 Tcl_Obj *listPtr; 2810 int index, isDuplicate, len, result; 2811 2812 if (objc < 4) { 2813 Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?"); 2814 return TCL_ERROR; 2815 } 2816 2817 result = Tcl_ListObjLength(interp, objv[1], &len); 2818 if (result != TCL_OK) { 2819 return result; 2820 } 2821 2822 /* 2823 * Get the index. "end" is interpreted to be the index after the last 2824 * element, such that using it will cause any inserted elements to be 2825 * appended to the list. 2826 */ 2827 2828 result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index); 2829 if (result != TCL_OK) { 2830 return result; 2831 } 2832 if (index > len) { 2833 index = len; 2834 } 2835 2836 /* 2837 * If the list object is unshared we can modify it directly. Otherwise 2838 * we create a copy to modify: this is "copy on write". 2839 */ 2840 2841 listPtr = objv[1]; 2842 isDuplicate = 0; 2843 if (Tcl_IsShared(listPtr)) { 2844 listPtr = Tcl_DuplicateObj(listPtr); 2845 isDuplicate = 1; 2846 } 2847 2848 if ((objc == 4) && (index == len)) { 2849 /* 2850 * Special case: insert one element at the end of the list. 2851 */ 2852 result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]); 2853 } else if (objc > 3) { 2854 result = Tcl_ListObjReplace(interp, listPtr, index, 0, 2855 (objc-3), &(objv[3])); 2856 } 2857 if (result != TCL_OK) { 2858 if (isDuplicate) { 2859 Tcl_DecrRefCount(listPtr); /* free unneeded obj */ 2860 } 2861 return result; 2862 } 2863 2864 /* 2865 * Set the interpreter's object result. 2866 */ 2867 2868 Tcl_SetObjResult(interp, listPtr); 2869 return TCL_OK; 2870} 2871 2872/* 2873 *---------------------------------------------------------------------- 2874 * 2875 * Tcl_ListObjCmd -- 2876 * 2877 * This procedure is invoked to process the "list" Tcl command. 2878 * See the user documentation for details on what it does. 2879 * 2880 * Results: 2881 * A standard Tcl object result. 2882 * 2883 * Side effects: 2884 * See the user documentation. 2885 * 2886 *---------------------------------------------------------------------- 2887 */ 2888 2889 /* ARGSUSED */ 2890int 2891Tcl_ListObjCmd(dummy, interp, objc, objv) 2892 ClientData dummy; /* Not used. */ 2893 Tcl_Interp *interp; /* Current interpreter. */ 2894 register int objc; /* Number of arguments. */ 2895 register Tcl_Obj *CONST objv[]; /* The argument objects. */ 2896{ 2897 /* 2898 * If there are no list elements, the result is an empty object. 2899 * Otherwise modify the interpreter's result object to be a list object. 2900 */ 2901 2902 if (objc > 1) { 2903 Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1])); 2904 } 2905 return TCL_OK; 2906} 2907 2908/* 2909 *---------------------------------------------------------------------- 2910 * 2911 * Tcl_LlengthObjCmd -- 2912 * 2913 * This object-based procedure is invoked to process the "llength" Tcl 2914 * command. See the user documentation for details on what it does. 2915 * 2916 * Results: 2917 * A standard Tcl object result. 2918 * 2919 * Side effects: 2920 * See the user documentation. 2921 * 2922 *---------------------------------------------------------------------- 2923 */ 2924 2925 /* ARGSUSED */ 2926int 2927Tcl_LlengthObjCmd(dummy, interp, objc, objv) 2928 ClientData dummy; /* Not used. */ 2929 Tcl_Interp *interp; /* Current interpreter. */ 2930 int objc; /* Number of arguments. */ 2931 register Tcl_Obj *CONST objv[]; /* Argument objects. */ 2932{ 2933 int listLen, result; 2934 2935 if (objc != 2) { 2936 Tcl_WrongNumArgs(interp, 1, objv, "list"); 2937 return TCL_ERROR; 2938 } 2939 2940 result = Tcl_ListObjLength(interp, objv[1], &listLen); 2941 if (result != TCL_OK) { 2942 return result; 2943 } 2944 2945 /* 2946 * Set the interpreter's object result to an integer object holding the 2947 * length. 2948 */ 2949 2950 Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen); 2951 return TCL_OK; 2952} 2953 2954/* 2955 *---------------------------------------------------------------------- 2956 * 2957 * Tcl_LrangeObjCmd -- 2958 * 2959 * This procedure is invoked to process the "lrange" Tcl command. 2960 * See the user documentation for details on what it does. 2961 * 2962 * Results: 2963 * A standard Tcl object result. 2964 * 2965 * Side effects: 2966 * See the user documentation. 2967 * 2968 *---------------------------------------------------------------------- 2969 */ 2970 2971 /* ARGSUSED */ 2972int 2973Tcl_LrangeObjCmd(notUsed, interp, objc, objv) 2974 ClientData notUsed; /* Not used. */ 2975 Tcl_Interp *interp; /* Current interpreter. */ 2976 int objc; /* Number of arguments. */ 2977 register Tcl_Obj *CONST objv[]; /* Argument objects. */ 2978{ 2979 Tcl_Obj *listPtr; 2980 Tcl_Obj **elemPtrs; 2981 int listLen, first, last, numElems, result; 2982 2983 if (objc != 4) { 2984 Tcl_WrongNumArgs(interp, 1, objv, "list first last"); 2985 return TCL_ERROR; 2986 } 2987 2988 /* 2989 * Make sure the list argument is a list object and get its length and 2990 * a pointer to its array of element pointers. 2991 */ 2992 2993 listPtr = objv[1]; 2994 result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); 2995 if (result != TCL_OK) { 2996 return result; 2997 } 2998 2999 /* 3000 * Get the first and last indexes. 3001 */ 3002 3003 result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1), 3004 &first); 3005 if (result != TCL_OK) { 3006 return result; 3007 } 3008 if (first < 0) { 3009 first = 0; 3010 } 3011 3012 result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1), 3013 &last); 3014 if (result != TCL_OK) { 3015 return result; 3016 } 3017 if (last >= listLen) { 3018 last = (listLen - 1); 3019 } 3020 3021 if (first > last) { 3022 return TCL_OK; /* the result is an empty object */ 3023 } 3024 3025 /* 3026 * Make sure listPtr still refers to a list object. It might have been 3027 * converted to an int above if the argument objects were shared. 3028 */ 3029 3030 if (listPtr->typePtr != &tclListType) { 3031 result = Tcl_ListObjGetElements(interp, listPtr, &listLen, 3032 &elemPtrs); 3033 if (result != TCL_OK) { 3034 return result; 3035 } 3036 } 3037 3038 /* 3039 * Extract a range of fields. We modify the interpreter's result object 3040 * to be a list object containing the specified elements. 3041 */ 3042 3043 numElems = (last - first + 1); 3044 Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first])); 3045 return TCL_OK; 3046} 3047 3048/* 3049 *---------------------------------------------------------------------- 3050 * 3051 * Tcl_LreplaceObjCmd -- 3052 * 3053 * This object-based procedure is invoked to process the "lreplace" 3054 * Tcl command. See the user documentation for details on what it does. 3055 * 3056 * Results: 3057 * A new Tcl list object formed by replacing zero or more elements of 3058 * a list. 3059 * 3060 * Side effects: 3061 * See the user documentation. 3062 * 3063 *---------------------------------------------------------------------- 3064 */ 3065 3066 /* ARGSUSED */ 3067int 3068Tcl_LreplaceObjCmd(dummy, interp, objc, objv) 3069 ClientData dummy; /* Not used. */ 3070 Tcl_Interp *interp; /* Current interpreter. */ 3071 int objc; /* Number of arguments. */ 3072 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3073{ 3074 register Tcl_Obj *listPtr; 3075 int isDuplicate, first, last, listLen, numToDelete, result; 3076 3077 if (objc < 4) { 3078 Tcl_WrongNumArgs(interp, 1, objv, 3079 "list first last ?element element ...?"); 3080 return TCL_ERROR; 3081 } 3082 3083 result = Tcl_ListObjLength(interp, objv[1], &listLen); 3084 if (result != TCL_OK) { 3085 return result; 3086 } 3087 3088 /* 3089 * Get the first and last indexes. "end" is interpreted to be the index 3090 * for the last element, such that using it will cause that element to 3091 * be included for deletion. 3092 */ 3093 3094 result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first); 3095 if (result != TCL_OK) { 3096 return result; 3097 } 3098 3099 result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last); 3100 if (result != TCL_OK) { 3101 return result; 3102 } 3103 3104 if (first < 0) { 3105 first = 0; 3106 } 3107 3108 /* 3109 * Complain if the user asked for a start element that is greater than the 3110 * list length. This won't ever trigger for the "end*" case as that will 3111 * be properly constrained by TclGetIntForIndex because we use listLen-1 3112 * (to allow for replacing the last elem). 3113 */ 3114 3115 if ((first >= listLen) && (listLen > 0)) { 3116 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 3117 "list doesn't contain element ", 3118 Tcl_GetString(objv[2]), (int *) NULL); 3119 return TCL_ERROR; 3120 } 3121 if (last >= listLen) { 3122 last = (listLen - 1); 3123 } 3124 if (first <= last) { 3125 numToDelete = (last - first + 1); 3126 } else { 3127 numToDelete = 0; 3128 } 3129 3130 /* 3131 * If the list object is unshared we can modify it directly, otherwise 3132 * we create a copy to modify: this is "copy on write". 3133 */ 3134 3135 listPtr = objv[1]; 3136 isDuplicate = 0; 3137 if (Tcl_IsShared(listPtr)) { 3138 listPtr = Tcl_DuplicateObj(listPtr); 3139 isDuplicate = 1; 3140 } 3141 if (objc > 4) { 3142 result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, 3143 (objc-4), &(objv[4])); 3144 } else { 3145 result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, 3146 0, NULL); 3147 } 3148 if (result != TCL_OK) { 3149 if (isDuplicate) { 3150 Tcl_DecrRefCount(listPtr); /* free unneeded obj */ 3151 } 3152 return result; 3153 } 3154 3155 /* 3156 * Set the interpreter's object result. 3157 */ 3158 3159 Tcl_SetObjResult(interp, listPtr); 3160 return TCL_OK; 3161} 3162 3163/* 3164 *---------------------------------------------------------------------- 3165 * 3166 * Tcl_LsearchObjCmd -- 3167 * 3168 * This procedure is invoked to process the "lsearch" Tcl command. 3169 * See the user documentation for details on what it does. 3170 * 3171 * Results: 3172 * A standard Tcl result. 3173 * 3174 * Side effects: 3175 * See the user documentation. 3176 * 3177 *---------------------------------------------------------------------- 3178 */ 3179 3180int 3181Tcl_LsearchObjCmd(clientData, interp, objc, objv) 3182 ClientData clientData; /* Not used. */ 3183 Tcl_Interp *interp; /* Current interpreter. */ 3184 int objc; /* Number of arguments. */ 3185 Tcl_Obj *CONST objv[]; /* Argument values. */ 3186{ 3187 char *bytes, *patternBytes; 3188 int i, match, mode, index, result, listc, length, elemLen; 3189 int dataType, isIncreasing, lower, upper, patInt, objInt; 3190 int offset, allMatches, inlineReturn, negatedMatch; 3191 double patDouble, objDouble; 3192 Tcl_Obj *patObj, **listv, *listPtr, *startPtr; 3193 Tcl_RegExp regexp = NULL; 3194 static CONST char *options[] = { 3195 "-all", "-ascii", "-decreasing", "-dictionary", 3196 "-exact", "-glob", "-increasing", "-inline", 3197 "-integer", "-not", "-real", "-regexp", 3198 "-sorted", "-start", NULL 3199 }; 3200 enum options { 3201 LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY, 3202 LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INLINE, 3203 LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, 3204 LSEARCH_SORTED, LSEARCH_START 3205 }; 3206 enum datatypes { 3207 ASCII, DICTIONARY, INTEGER, REAL 3208 }; 3209 enum modes { 3210 EXACT, GLOB, REGEXP, SORTED 3211 }; 3212 3213 mode = GLOB; 3214 dataType = ASCII; 3215 isIncreasing = 1; 3216 allMatches = 0; 3217 inlineReturn = 0; 3218 negatedMatch = 0; 3219 listPtr = NULL; 3220 startPtr = NULL; 3221 offset = 0; 3222 3223 if (objc < 3) { 3224 Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern"); 3225 return TCL_ERROR; 3226 } 3227 3228 for (i = 1; i < objc-2; i++) { 3229 if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) 3230 != TCL_OK) { 3231 if (startPtr) { 3232 Tcl_DecrRefCount(startPtr); 3233 } 3234 return TCL_ERROR; 3235 } 3236 switch ((enum options) index) { 3237 case LSEARCH_ALL: /* -all */ 3238 allMatches = 1; 3239 break; 3240 case LSEARCH_ASCII: /* -ascii */ 3241 dataType = ASCII; 3242 break; 3243 case LSEARCH_DECREASING: /* -decreasing */ 3244 isIncreasing = 0; 3245 break; 3246 case LSEARCH_DICTIONARY: /* -dictionary */ 3247 dataType = DICTIONARY; 3248 break; 3249 case LSEARCH_EXACT: /* -increasing */ 3250 mode = EXACT; 3251 break; 3252 case LSEARCH_GLOB: /* -glob */ 3253 mode = GLOB; 3254 break; 3255 case LSEARCH_INCREASING: /* -increasing */ 3256 isIncreasing = 1; 3257 break; 3258 case LSEARCH_INLINE: /* -inline */ 3259 inlineReturn = 1; 3260 break; 3261 case LSEARCH_INTEGER: /* -integer */ 3262 dataType = INTEGER; 3263 break; 3264 case LSEARCH_NOT: /* -not */ 3265 negatedMatch = 1; 3266 break; 3267 case LSEARCH_REAL: /* -real */ 3268 dataType = REAL; 3269 break; 3270 case LSEARCH_REGEXP: /* -regexp */ 3271 mode = REGEXP; 3272 break; 3273 case LSEARCH_SORTED: /* -sorted */ 3274 mode = SORTED; 3275 break; 3276 case LSEARCH_START: /* -start */ 3277 /* 3278 * If there was a previous -start option, release its saved 3279 * index because it will either be replaced or there will be 3280 * an error. 3281 */ 3282 if (startPtr) { 3283 Tcl_DecrRefCount(startPtr); 3284 } 3285 if (i > objc-4) { 3286 Tcl_AppendResult(interp, "missing starting index", NULL); 3287 return TCL_ERROR; 3288 } 3289 i++; 3290 if (objv[i] == objv[objc - 2]) { 3291 /* 3292 * Take copy to prevent shimmering problems. Note 3293 * that it does not matter if the index obj is also a 3294 * component of the list being searched. We only need 3295 * to copy where the list and the index are 3296 * one-and-the-same. 3297 */ 3298 startPtr = Tcl_DuplicateObj(objv[i]); 3299 } else { 3300 startPtr = objv[i]; 3301 Tcl_IncrRefCount(startPtr); 3302 } 3303 } 3304 } 3305 3306 if ((enum modes) mode == REGEXP) { 3307 /* 3308 * We can shimmer regexp/list if listv[i] == pattern, so get the 3309 * regexp rep before the list rep. First time round, omit the interp 3310 * and hope that the compilation will succeed. If it fails, we'll 3311 * recompile in "expensive" mode with a place to put error messages. 3312 */ 3313 3314 regexp = Tcl_GetRegExpFromObj(NULL, objv[objc - 1], 3315 TCL_REG_ADVANCED | TCL_REG_NOSUB); 3316 if (regexp == NULL) { 3317 /* 3318 * Failed to compile the RE. Try again without the TCL_REG_NOSUB 3319 * flag in case the RE had sub-expressions in it [Bug 1366683]. 3320 * If this fails, an error message will be left in the 3321 * interpreter. 3322 */ 3323 3324 regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], 3325 TCL_REG_ADVANCED); 3326 } 3327 3328 if (regexp == NULL) { 3329 if (startPtr) { 3330 Tcl_DecrRefCount(startPtr); 3331 } 3332 return TCL_ERROR; 3333 } 3334 } 3335 3336 /* 3337 * Make sure the list argument is a list object and get its length and 3338 * a pointer to its array of element pointers. 3339 */ 3340 3341 result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); 3342 if (result != TCL_OK) { 3343 if (startPtr) { 3344 Tcl_DecrRefCount(startPtr); 3345 } 3346 return result; 3347 } 3348 3349 /* 3350 * Get the user-specified start offset. 3351 */ 3352 if (startPtr) { 3353 result = TclGetIntForIndex(interp, startPtr, listc-1, &offset); 3354 Tcl_DecrRefCount(startPtr); 3355 if (result != TCL_OK) { 3356 return result; 3357 } 3358 3359 /* 3360 * If the search started past the end of the list, we just return a 3361 * "did not match anything at all" result straight away. [Bug 1374778] 3362 */ 3363 3364 if (offset > listc-1) { 3365 if (allMatches || inlineReturn) { 3366 Tcl_ResetResult(interp); 3367 } else { 3368 Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); 3369 } 3370 return TCL_OK; 3371 } 3372 if (offset < 0) { 3373 offset = 0; 3374 } 3375 } 3376 3377 patObj = objv[objc - 1]; 3378 patternBytes = NULL; 3379 if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) { 3380 switch ((enum datatypes) dataType) { 3381 case ASCII: 3382 case DICTIONARY: 3383 patternBytes = Tcl_GetStringFromObj(patObj, &length); 3384 break; 3385 case INTEGER: 3386 result = Tcl_GetIntFromObj(interp, patObj, &patInt); 3387 if (result != TCL_OK) { 3388 return result; 3389 } 3390 Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv); 3391 break; 3392 case REAL: 3393 result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); 3394 if (result != TCL_OK) { 3395 return result; 3396 } 3397 Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv); 3398 break; 3399 } 3400 } else { 3401 patternBytes = Tcl_GetStringFromObj(patObj, &length); 3402 } 3403 3404 /* 3405 * Set default index value to -1, indicating failure; if we find the 3406 * item in the course of our search, index will be set to the correct 3407 * value. 3408 */ 3409 index = -1; 3410 match = 0; 3411 3412 if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) { 3413 /* 3414 * If the data is sorted, we can do a more intelligent search. 3415 * Note that there is no point in being smart when -all was 3416 * specified; in that case, we have to look at all items anyway, 3417 * and there is no sense in doing this when the match sense is 3418 * inverted. 3419 */ 3420 lower = offset - 1; 3421 upper = listc; 3422 while (lower + 1 != upper) { 3423 i = (lower + upper)/2; 3424 switch ((enum datatypes) dataType) { 3425 case ASCII: 3426 bytes = Tcl_GetString(listv[i]); 3427 match = strcmp(patternBytes, bytes); 3428 break; 3429 case DICTIONARY: 3430 bytes = Tcl_GetString(listv[i]); 3431 match = DictionaryCompare(patternBytes, bytes); 3432 break; 3433 case INTEGER: 3434 result = Tcl_GetIntFromObj(interp, listv[i], &objInt); 3435 if (result != TCL_OK) { 3436 return result; 3437 } 3438 if (patInt == objInt) { 3439 match = 0; 3440 } else if (patInt < objInt) { 3441 match = -1; 3442 } else { 3443 match = 1; 3444 } 3445 break; 3446 case REAL: 3447 result = Tcl_GetDoubleFromObj(interp, listv[i], &objDouble); 3448 if (result != TCL_OK) { 3449 return result; 3450 } 3451 if (patDouble == objDouble) { 3452 match = 0; 3453 } else if (patDouble < objDouble) { 3454 match = -1; 3455 } else { 3456 match = 1; 3457 } 3458 break; 3459 } 3460 if (match == 0) { 3461 /* 3462 * Normally, binary search is written to stop when it 3463 * finds a match. If there are duplicates of an element in 3464 * the list, our first match might not be the first occurance. 3465 * Consider: 0 0 0 1 1 1 2 2 2 3466 * To maintain consistancy with standard lsearch semantics, 3467 * we must find the leftmost occurance of the pattern in the 3468 * list. Thus we don't just stop searching here. This 3469 * variation means that a search always makes log n 3470 * comparisons (normal binary search might "get lucky" with 3471 * an early comparison). 3472 */ 3473 index = i; 3474 upper = i; 3475 } else if (match > 0) { 3476 if (isIncreasing) { 3477 lower = i; 3478 } else { 3479 upper = i; 3480 } 3481 } else { 3482 if (isIncreasing) { 3483 upper = i; 3484 } else { 3485 lower = i; 3486 } 3487 } 3488 } 3489 3490 } else { 3491 /* 3492 * We need to do a linear search, because (at least one) of: 3493 * - our matcher can only tell equal vs. not equal 3494 * - our matching sense is negated 3495 * - we're building a list of all matched items 3496 */ 3497 if (allMatches) { 3498 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3499 } 3500 for (i = offset; i < listc; i++) { 3501 match = 0; 3502 switch ((enum modes) mode) { 3503 case SORTED: 3504 case EXACT: 3505 switch ((enum datatypes) dataType) { 3506 case ASCII: 3507 bytes = Tcl_GetStringFromObj(listv[i], &elemLen); 3508 if (length == elemLen) { 3509 match = (memcmp(bytes, patternBytes, 3510 (size_t) length) == 0); 3511 } 3512 break; 3513 case DICTIONARY: 3514 bytes = Tcl_GetString(listv[i]); 3515 match = (DictionaryCompare(bytes, patternBytes) == 0); 3516 break; 3517 case INTEGER: 3518 result = Tcl_GetIntFromObj(interp, listv[i], &objInt); 3519 if (result != TCL_OK) { 3520 if (listPtr) { 3521 Tcl_DecrRefCount(listPtr); 3522 } 3523 return result; 3524 } 3525 match = (objInt == patInt); 3526 break; 3527 case REAL: 3528 result = Tcl_GetDoubleFromObj(interp, listv[i], 3529 &objDouble); 3530 if (result != TCL_OK) { 3531 if (listPtr) { 3532 Tcl_DecrRefCount(listPtr); 3533 } 3534 return result; 3535 } 3536 match = (objDouble == patDouble); 3537 break; 3538 } 3539 break; 3540 case GLOB: 3541 match = Tcl_StringMatch(Tcl_GetString(listv[i]), 3542 patternBytes); 3543 break; 3544 case REGEXP: 3545 match = Tcl_RegExpExecObj(interp, regexp, listv[i], 0, 0, 0); 3546 if (match < 0) { 3547 Tcl_DecrRefCount(patObj); 3548 if (listPtr) { 3549 Tcl_DecrRefCount(listPtr); 3550 } 3551 return TCL_ERROR; 3552 } 3553 break; 3554 } 3555 /* 3556 * Invert match condition for -not 3557 */ 3558 if (negatedMatch) { 3559 match = !match; 3560 } 3561 if (match != 0) { 3562 if (!allMatches) { 3563 index = i; 3564 break; 3565 } else if (inlineReturn) { 3566 /* 3567 * Note that these appends are not expected to fail. 3568 */ 3569 Tcl_ListObjAppendElement(interp, listPtr, listv[i]); 3570 } else { 3571 Tcl_ListObjAppendElement(interp, listPtr, 3572 Tcl_NewIntObj(i)); 3573 } 3574 } 3575 } 3576 } 3577 3578 /* 3579 * Return everything or a single value. 3580 */ 3581 if (allMatches) { 3582 Tcl_SetObjResult(interp, listPtr); 3583 } else if (!inlineReturn) { 3584 Tcl_SetIntObj(Tcl_GetObjResult(interp), index); 3585 } else if (index < 0) { 3586 /* 3587 * Is this superfluous? The result should be a blank object 3588 * by default... 3589 */ 3590 Tcl_SetObjResult(interp, Tcl_NewObj()); 3591 } else { 3592 Tcl_SetObjResult(interp, listv[index]); 3593 } 3594 return TCL_OK; 3595} 3596 3597/* 3598 *---------------------------------------------------------------------- 3599 * 3600 * Tcl_LsetObjCmd -- 3601 * 3602 * This procedure is invoked to process the "lset" Tcl command. 3603 * See the user documentation for details on what it does. 3604 * 3605 * Results: 3606 * A standard Tcl result. 3607 * 3608 * Side effects: 3609 * See the user documentation. 3610 * 3611 *---------------------------------------------------------------------- 3612 */ 3613 3614int 3615Tcl_LsetObjCmd( clientData, interp, objc, objv ) 3616 ClientData clientData; /* Not used. */ 3617 Tcl_Interp *interp; /* Current interpreter. */ 3618 int objc; /* Number of arguments. */ 3619 Tcl_Obj *CONST objv[]; /* Argument values. */ 3620{ 3621 3622 Tcl_Obj* listPtr; /* Pointer to the list being altered. */ 3623 Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable */ 3624 3625 /* Check parameter count */ 3626 3627 if ( objc < 3 ) { 3628 Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" ); 3629 return TCL_ERROR; 3630 } 3631 3632 /* Look up the list variable's value */ 3633 3634 listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL, 3635 TCL_LEAVE_ERR_MSG ); 3636 if ( listPtr == NULL ) { 3637 return TCL_ERROR; 3638 } 3639 3640 /* 3641 * Substitute the value in the value. Return either the value or 3642 * else an unshared copy of it. 3643 */ 3644 3645 if ( objc == 4 ) { 3646 finalValuePtr = TclLsetList( interp, listPtr, 3647 objv[ 2 ], objv[ 3 ] ); 3648 } else { 3649 finalValuePtr = TclLsetFlat( interp, listPtr, 3650 objc-3, objv+2, objv[ objc-1 ] ); 3651 } 3652 3653 /* 3654 * If substitution has failed, bail out. 3655 */ 3656 3657 if ( finalValuePtr == NULL ) { 3658 return TCL_ERROR; 3659 } 3660 3661 /* Finally, update the variable so that traces fire. */ 3662 3663 listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr, 3664 TCL_LEAVE_ERR_MSG ); 3665 Tcl_DecrRefCount( finalValuePtr ); 3666 if ( listPtr == NULL ) { 3667 return TCL_ERROR; 3668 } 3669 3670 /* Return the new value of the variable as the interpreter result. */ 3671 3672 Tcl_SetObjResult( interp, listPtr ); 3673 return TCL_OK; 3674 3675} 3676 3677/* 3678 *---------------------------------------------------------------------- 3679 * 3680 * Tcl_LsortObjCmd -- 3681 * 3682 * This procedure is invoked to process the "lsort" Tcl command. 3683 * See the user documentation for details on what it does. 3684 * 3685 * Results: 3686 * A standard Tcl result. 3687 * 3688 * Side effects: 3689 * See the user documentation. 3690 * 3691 *---------------------------------------------------------------------- 3692 */ 3693 3694int 3695Tcl_LsortObjCmd(clientData, interp, objc, objv) 3696 ClientData clientData; /* Not used. */ 3697 Tcl_Interp *interp; /* Current interpreter. */ 3698 int objc; /* Number of arguments. */ 3699 Tcl_Obj *CONST objv[]; /* Argument values. */ 3700{ 3701 int i, index, unique; 3702 Tcl_Obj *resultPtr; 3703 int length; 3704 Tcl_Obj *cmdPtr, **listObjPtrs; 3705 SortElement *elementArray; 3706 SortElement *elementPtr; 3707 SortInfo sortInfo; /* Information about this sort that 3708 * needs to be passed to the 3709 * comparison function */ 3710 static CONST char *switches[] = { 3711 "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", 3712 "-index", "-integer", "-real", "-unique", (char *) NULL 3713 }; 3714 3715 resultPtr = Tcl_GetObjResult(interp); 3716 if (objc < 2) { 3717 Tcl_WrongNumArgs(interp, 1, objv, "?options? list"); 3718 return TCL_ERROR; 3719 } 3720 3721 /* 3722 * Parse arguments to set up the mode for the sort. 3723 */ 3724 3725 sortInfo.isIncreasing = 1; 3726 sortInfo.sortMode = SORTMODE_ASCII; 3727 sortInfo.index = SORTIDX_NONE; 3728 sortInfo.interp = interp; 3729 sortInfo.resultCode = TCL_OK; 3730 cmdPtr = NULL; 3731 unique = 0; 3732 for (i = 1; i < objc-1; i++) { 3733 if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) 3734 != TCL_OK) { 3735 return TCL_ERROR; 3736 } 3737 switch (index) { 3738 case 0: /* -ascii */ 3739 sortInfo.sortMode = SORTMODE_ASCII; 3740 break; 3741 case 1: /* -command */ 3742 if (i == (objc-2)) { 3743 Tcl_AppendToObj(resultPtr, 3744 "\"-command\" option must be followed by comparison command", 3745 -1); 3746 return TCL_ERROR; 3747 } 3748 sortInfo.sortMode = SORTMODE_COMMAND; 3749 cmdPtr = objv[i+1]; 3750 i++; 3751 break; 3752 case 2: /* -decreasing */ 3753 sortInfo.isIncreasing = 0; 3754 break; 3755 case 3: /* -dictionary */ 3756 sortInfo.sortMode = SORTMODE_DICTIONARY; 3757 break; 3758 case 4: /* -increasing */ 3759 sortInfo.isIncreasing = 1; 3760 break; 3761 case 5: /* -index */ 3762 if (i == (objc-2)) { 3763 Tcl_AppendToObj(resultPtr, 3764 "\"-index\" option must be followed by list index", 3765 -1); 3766 return TCL_ERROR; 3767 } 3768 if (TclGetIntForIndex(interp, objv[i+1], SORTIDX_END, 3769 &sortInfo.index) != TCL_OK) { 3770 return TCL_ERROR; 3771 } 3772 i++; 3773 break; 3774 case 6: /* -integer */ 3775 sortInfo.sortMode = SORTMODE_INTEGER; 3776 break; 3777 case 7: /* -real */ 3778 sortInfo.sortMode = SORTMODE_REAL; 3779 break; 3780 case 8: /* -unique */ 3781 unique = 1; 3782 break; 3783 } 3784 } 3785 if (sortInfo.sortMode == SORTMODE_COMMAND) { 3786 /* 3787 * The existing command is a list. We want to flatten it, append 3788 * two dummy arguments on the end, and replace these arguments 3789 * later. 3790 */ 3791 3792 Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); 3793 Tcl_Obj *newObjPtr = Tcl_NewObj(); 3794 3795 Tcl_IncrRefCount(newCommandPtr); 3796 if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr) 3797 != TCL_OK) { 3798 Tcl_DecrRefCount(newCommandPtr); 3799 Tcl_IncrRefCount(newObjPtr); 3800 Tcl_DecrRefCount(newObjPtr); 3801 return TCL_ERROR; 3802 } 3803 Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); 3804 sortInfo.compareCmdPtr = newCommandPtr; 3805 } 3806 3807 sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1], 3808 &length, &listObjPtrs); 3809 if (sortInfo.resultCode != TCL_OK || length <= 0) { 3810 goto done; 3811 } 3812 elementArray = (SortElement *) ckalloc(length * sizeof(SortElement)); 3813 for (i=0; i < length; i++){ 3814 elementArray[i].objPtr = listObjPtrs[i]; 3815 elementArray[i].count = 0; 3816 elementArray[i].nextPtr = &elementArray[i+1]; 3817 3818 /* 3819 * When sorting using a command, we are reentrant and therefore might 3820 * have the representation of the list being sorted shimmered out from 3821 * underneath our feet. Increment the reference counts of the elements 3822 * to sort to prevent this. [Bug 1675116] 3823 */ 3824 3825 Tcl_IncrRefCount(elementArray[i].objPtr); 3826 } 3827 elementArray[length-1].nextPtr = NULL; 3828 elementPtr = MergeSort(elementArray, &sortInfo); 3829 if (sortInfo.resultCode == TCL_OK) { 3830 /* 3831 * Note: must clear the interpreter's result object: it could 3832 * have been set by the -command script. 3833 */ 3834 3835 Tcl_ResetResult(interp); 3836 resultPtr = Tcl_GetObjResult(interp); 3837 if (unique) { 3838 for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){ 3839 if (elementPtr->count == 0) { 3840 Tcl_ListObjAppendElement(interp, resultPtr, 3841 elementPtr->objPtr); 3842 } 3843 } 3844 } else { 3845 for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){ 3846 Tcl_ListObjAppendElement(interp, resultPtr, 3847 elementPtr->objPtr); 3848 } 3849 } 3850 } 3851 for (i=0; i<length; i++) { 3852 Tcl_DecrRefCount(elementArray[i].objPtr); 3853 } 3854 ckfree((char*) elementArray); 3855 3856 done: 3857 if (sortInfo.sortMode == SORTMODE_COMMAND) { 3858 Tcl_DecrRefCount(sortInfo.compareCmdPtr); 3859 sortInfo.compareCmdPtr = NULL; 3860 } 3861 return sortInfo.resultCode; 3862} 3863 3864/* 3865 *---------------------------------------------------------------------- 3866 * 3867 * MergeSort - 3868 * 3869 * This procedure sorts a linked list of SortElement structures 3870 * use the merge-sort algorithm. 3871 * 3872 * Results: 3873 * A pointer to the head of the list after sorting is returned. 3874 * 3875 * Side effects: 3876 * None, unless a user-defined comparison command does something 3877 * weird. 3878 * 3879 *---------------------------------------------------------------------- 3880 */ 3881 3882static SortElement * 3883MergeSort(headPtr, infoPtr) 3884 SortElement *headPtr; /* First element on the list */ 3885 SortInfo *infoPtr; /* Information needed by the 3886 * comparison operator */ 3887{ 3888 /* 3889 * The subList array below holds pointers to temporary lists built 3890 * during the merge sort. Element i of the array holds a list of 3891 * length 2**i. 3892 */ 3893 3894# define NUM_LISTS 30 3895 SortElement *subList[NUM_LISTS]; 3896 SortElement *elementPtr; 3897 int i; 3898 3899 for(i = 0; i < NUM_LISTS; i++){ 3900 subList[i] = NULL; 3901 } 3902 while (headPtr != NULL) { 3903 elementPtr = headPtr; 3904 headPtr = headPtr->nextPtr; 3905 elementPtr->nextPtr = 0; 3906 for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){ 3907 elementPtr = MergeLists(subList[i], elementPtr, infoPtr); 3908 subList[i] = NULL; 3909 } 3910 if (i >= NUM_LISTS) { 3911 i = NUM_LISTS-1; 3912 } 3913 subList[i] = elementPtr; 3914 } 3915 elementPtr = NULL; 3916 for (i = 0; i < NUM_LISTS; i++){ 3917 elementPtr = MergeLists(subList[i], elementPtr, infoPtr); 3918 } 3919 return elementPtr; 3920} 3921 3922/* 3923 *---------------------------------------------------------------------- 3924 * 3925 * MergeLists - 3926 * 3927 * This procedure combines two sorted lists of SortElement structures 3928 * into a single sorted list. 3929 * 3930 * Results: 3931 * The unified list of SortElement structures. 3932 * 3933 * Side effects: 3934 * None, unless a user-defined comparison command does something 3935 * weird. 3936 * 3937 *---------------------------------------------------------------------- 3938 */ 3939 3940static SortElement * 3941MergeLists(leftPtr, rightPtr, infoPtr) 3942 SortElement *leftPtr; /* First list to be merged; may be 3943 * NULL. */ 3944 SortElement *rightPtr; /* Second list to be merged; may be 3945 * NULL. */ 3946 SortInfo *infoPtr; /* Information needed by the 3947 * comparison operator. */ 3948{ 3949 SortElement *headPtr; 3950 SortElement *tailPtr; 3951 int cmp; 3952 3953 if (leftPtr == NULL) { 3954 return rightPtr; 3955 } 3956 if (rightPtr == NULL) { 3957 return leftPtr; 3958 } 3959 cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr); 3960 if (cmp > 0) { 3961 tailPtr = rightPtr; 3962 rightPtr = rightPtr->nextPtr; 3963 } else { 3964 if (cmp == 0) { 3965 leftPtr->count++; 3966 } 3967 tailPtr = leftPtr; 3968 leftPtr = leftPtr->nextPtr; 3969 } 3970 headPtr = tailPtr; 3971 while ((leftPtr != NULL) && (rightPtr != NULL)) { 3972 cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr); 3973 if (cmp > 0) { 3974 tailPtr->nextPtr = rightPtr; 3975 tailPtr = rightPtr; 3976 rightPtr = rightPtr->nextPtr; 3977 } else { 3978 if (cmp == 0) { 3979 leftPtr->count++; 3980 } 3981 tailPtr->nextPtr = leftPtr; 3982 tailPtr = leftPtr; 3983 leftPtr = leftPtr->nextPtr; 3984 } 3985 } 3986 if (leftPtr != NULL) { 3987 tailPtr->nextPtr = leftPtr; 3988 } else { 3989 tailPtr->nextPtr = rightPtr; 3990 } 3991 return headPtr; 3992} 3993 3994/* 3995 *---------------------------------------------------------------------- 3996 * 3997 * SortCompare -- 3998 * 3999 * This procedure is invoked by MergeLists to determine the proper 4000 * ordering between two elements. 4001 * 4002 * Results: 4003 * A negative results means the the first element comes before the 4004 * second, and a positive results means that the second element 4005 * should come first. A result of zero means the two elements 4006 * are equal and it doesn't matter which comes first. 4007 * 4008 * Side effects: 4009 * None, unless a user-defined comparison command does something 4010 * weird. 4011 * 4012 *---------------------------------------------------------------------- 4013 */ 4014 4015static int 4016SortCompare(objPtr1, objPtr2, infoPtr) 4017 Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */ 4018 SortInfo *infoPtr; /* Information passed from the 4019 * top-level "lsort" command */ 4020{ 4021 int order, listLen, index; 4022 Tcl_Obj *objPtr; 4023 char buffer[TCL_INTEGER_SPACE]; 4024 4025 order = 0; 4026 if (infoPtr->resultCode != TCL_OK) { 4027 /* 4028 * Once an error has occurred, skip any future comparisons 4029 * so as to preserve the error message in sortInterp->result. 4030 */ 4031 4032 return order; 4033 } 4034 if (infoPtr->index != SORTIDX_NONE) { 4035 /* 4036 * The "-index" option was specified. Treat each object as a 4037 * list, extract the requested element from each list, and 4038 * compare the elements, not the lists. "end"-relative indices 4039 * are signaled here with large negative values. 4040 */ 4041 4042 if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) { 4043 infoPtr->resultCode = TCL_ERROR; 4044 return order; 4045 } 4046 if (infoPtr->index < SORTIDX_NONE) { 4047 index = listLen + infoPtr->index + 1; 4048 } else { 4049 index = infoPtr->index; 4050 } 4051 4052 if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr) 4053 != TCL_OK) { 4054 infoPtr->resultCode = TCL_ERROR; 4055 return order; 4056 } 4057 if (objPtr == NULL) { 4058 objPtr = objPtr1; 4059 missingElement: 4060 TclFormatInt(buffer, infoPtr->index); 4061 Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), 4062 "element ", buffer, " missing from sublist \"", 4063 Tcl_GetString(objPtr), "\"", (char *) NULL); 4064 infoPtr->resultCode = TCL_ERROR; 4065 return order; 4066 } 4067 objPtr1 = objPtr; 4068 4069 if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) { 4070 infoPtr->resultCode = TCL_ERROR; 4071 return order; 4072 } 4073 if (infoPtr->index < SORTIDX_NONE) { 4074 index = listLen + infoPtr->index + 1; 4075 } else { 4076 index = infoPtr->index; 4077 } 4078 4079 if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr) 4080 != TCL_OK) { 4081 infoPtr->resultCode = TCL_ERROR; 4082 return order; 4083 } 4084 if (objPtr == NULL) { 4085 objPtr = objPtr2; 4086 goto missingElement; 4087 } 4088 objPtr2 = objPtr; 4089 } 4090 if (infoPtr->sortMode == SORTMODE_ASCII) { 4091 order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); 4092 } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { 4093 order = DictionaryCompare( 4094 Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); 4095 } else if (infoPtr->sortMode == SORTMODE_INTEGER) { 4096 long a, b; 4097 4098 if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) 4099 || (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b) 4100 != TCL_OK)) { 4101 infoPtr->resultCode = TCL_ERROR; 4102 return order; 4103 } 4104 if (a > b) { 4105 order = 1; 4106 } else if (b > a) { 4107 order = -1; 4108 } 4109 } else if (infoPtr->sortMode == SORTMODE_REAL) { 4110 double a, b; 4111 4112 if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) 4113 || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b) 4114 != TCL_OK)) { 4115 infoPtr->resultCode = TCL_ERROR; 4116 return order; 4117 } 4118 if (a > b) { 4119 order = 1; 4120 } else if (b > a) { 4121 order = -1; 4122 } 4123 } else { 4124 Tcl_Obj **objv, *paramObjv[2]; 4125 int objc; 4126 4127 paramObjv[0] = objPtr1; 4128 paramObjv[1] = objPtr2; 4129 4130 /* 4131 * We made space in the command list for the two things to 4132 * compare. Replace them and evaluate the result. 4133 */ 4134 4135 Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); 4136 Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, 4137 2, 2, paramObjv); 4138 Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, 4139 &objc, &objv); 4140 4141 infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); 4142 4143 if (infoPtr->resultCode != TCL_OK) { 4144 Tcl_AddErrorInfo(infoPtr->interp, 4145 "\n (-compare command)"); 4146 return order; 4147 } 4148 4149 /* 4150 * Parse the result of the command. 4151 */ 4152 4153 if (Tcl_GetIntFromObj(infoPtr->interp, 4154 Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { 4155 Tcl_ResetResult(infoPtr->interp); 4156 Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp), 4157 "-compare command returned non-integer result", -1); 4158 infoPtr->resultCode = TCL_ERROR; 4159 return order; 4160 } 4161 } 4162 if (!infoPtr->isIncreasing) { 4163 order = -order; 4164 } 4165 return order; 4166} 4167 4168/* 4169 *---------------------------------------------------------------------- 4170 * 4171 * DictionaryCompare 4172 * 4173 * This function compares two strings as if they were being used in 4174 * an index or card catalog. The case of alphabetic characters is 4175 * ignored, except to break ties. Thus "B" comes before "b" but 4176 * after "a". Also, integers embedded in the strings compare in 4177 * numerical order. In other words, "x10y" comes after "x9y", not 4178 * before it as it would when using strcmp(). 4179 * 4180 * Results: 4181 * A negative result means that the first element comes before the 4182 * second, and a positive result means that the second element 4183 * should come first. A result of zero means the two elements 4184 * are equal and it doesn't matter which comes first. 4185 * 4186 * Side effects: 4187 * None. 4188 * 4189 *---------------------------------------------------------------------- 4190 */ 4191 4192static int 4193DictionaryCompare(left, right) 4194 char *left, *right; /* The strings to compare */ 4195{ 4196 Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower; 4197 int diff, zeros; 4198 int secondaryDiff = 0; 4199 4200 while (1) { 4201 if (isdigit(UCHAR(*right)) /* INTL: digit */ 4202 && isdigit(UCHAR(*left))) { /* INTL: digit */ 4203 /* 4204 * There are decimal numbers embedded in the two 4205 * strings. Compare them as numbers, rather than 4206 * strings. If one number has more leading zeros than 4207 * the other, the number with more leading zeros sorts 4208 * later, but only as a secondary choice. 4209 */ 4210 4211 zeros = 0; 4212 while ((*right == '0') && (isdigit(UCHAR(right[1])))) { 4213 right++; 4214 zeros--; 4215 } 4216 while ((*left == '0') && (isdigit(UCHAR(left[1])))) { 4217 left++; 4218 zeros++; 4219 } 4220 if (secondaryDiff == 0) { 4221 secondaryDiff = zeros; 4222 } 4223 4224 /* 4225 * The code below compares the numbers in the two 4226 * strings without ever converting them to integers. It 4227 * does this by first comparing the lengths of the 4228 * numbers and then comparing the digit values. 4229 */ 4230 4231 diff = 0; 4232 while (1) { 4233 if (diff == 0) { 4234 diff = UCHAR(*left) - UCHAR(*right); 4235 } 4236 right++; 4237 left++; 4238 if (!isdigit(UCHAR(*right))) { /* INTL: digit */ 4239 if (isdigit(UCHAR(*left))) { /* INTL: digit */ 4240 return 1; 4241 } else { 4242 /* 4243 * The two numbers have the same length. See 4244 * if their values are different. 4245 */ 4246 4247 if (diff != 0) { 4248 return diff; 4249 } 4250 break; 4251 } 4252 } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ 4253 return -1; 4254 } 4255 } 4256 continue; 4257 } 4258 4259 /* 4260 * Convert character to Unicode for comparison purposes. If either 4261 * string is at the terminating null, do a byte-wise comparison and 4262 * bail out immediately. 4263 */ 4264 4265 if ((*left != '\0') && (*right != '\0')) { 4266 left += Tcl_UtfToUniChar(left, &uniLeft); 4267 right += Tcl_UtfToUniChar(right, &uniRight); 4268 /* 4269 * Convert both chars to lower for the comparison, because 4270 * dictionary sorts are case insensitve. Covert to lower, not 4271 * upper, so chars between Z and a will sort before A (where most 4272 * other interesting punctuations occur) 4273 */ 4274 uniLeftLower = Tcl_UniCharToLower(uniLeft); 4275 uniRightLower = Tcl_UniCharToLower(uniRight); 4276 } else { 4277 diff = UCHAR(*left) - UCHAR(*right); 4278 break; 4279 } 4280 4281 diff = uniLeftLower - uniRightLower; 4282 if (diff) { 4283 return diff; 4284 } else if (secondaryDiff == 0) { 4285 if (Tcl_UniCharIsUpper(uniLeft) && 4286 Tcl_UniCharIsLower(uniRight)) { 4287 secondaryDiff = -1; 4288 } else if (Tcl_UniCharIsUpper(uniRight) 4289 && Tcl_UniCharIsLower(uniLeft)) { 4290 secondaryDiff = 1; 4291 } 4292 } 4293 } 4294 if (diff == 0) { 4295 diff = secondaryDiff; 4296 } 4297 return diff; 4298} 4299 4300/* 4301 * Local Variables: 4302 * mode: c 4303 * c-basic-offset: 4 4304 * fill-column: 78 4305 * End: 4306 */ 4307 4308