Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/generic/tclCmdIL.c @ 63

Last change on this file since 63 was 25, checked in by landauf, 17 years ago

added tcl to libs

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