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