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