source: HiSusy/trunk/Delphes/Delphes-3.0.9/external/tcl/tclCmdIL.c @ 5

Last change on this file since 5 was 5, checked in by zerwas, 11 years ago

update to Delphes-3.0.9
File size: 77.2 KB
Line 
1/*
2 * tclCmdIL.c --
3 *
4 *      This file contains the top-level command routines for most of
5 *      the Tcl built-in commands whose names begin with the letters
6 *      I through L.  It contains only commands in the generic core
7 *      (i.e. those that don't depend much upon UNIX facilities).
8 *
9 * Copyright (c) 1987-1993 The Regents of the University of California.
10 * Copyright (c) 1993-1997 Lucent Technologies.
11 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
12 * Copyright (c) 1998-1999 by Scriptics Corporation.
13 *
14 * See the file "license.terms" for information on usage and redistribution
15 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16 *
17 * RCS: @(#) $Id: tclCmdIL.c,v 1.1 2008-06-04 13:58:04 demin Exp $
18 */
19
20#include "tclInt.h"
21#include "tclPort.h"
22#include "tclCompile.h"
23
24/*
25 * During execution of the "lsort" command, structures of the following
26 * type are used to arrange the objects being sorted into a collection
27 * of linked lists.
28 */
29
30typedef struct SortElement {
31    Tcl_Obj *objPtr;                    /* Object being sorted. */
32    struct SortElement *nextPtr;        /* Next element in the list, or
33                                         * NULL for end of list. */
34} SortElement;
35
36/*
37 * The "lsort" command needs to pass certain information down to the
38 * function that compares two list elements, and the comparison function
39 * needs to pass success or failure information back up to the top-level
40 * "lsort" command.  The following structure is used to pass this
41 * information.
42 */
43
44typedef struct SortInfo {
45    int isIncreasing;           /* Nonzero means sort in increasing order. */
46    int sortMode;               /* The sort mode.  One of SORTMODE_*
47                                 * values defined below */
48    Tcl_DString compareCmd;     /* The Tcl comparison command when sortMode
49                                 * is SORTMODE_COMMAND.  Pre-initialized to
50                                 * hold base of command.*/
51    int index;                  /* If the -index option was specified, this
52                                 * holds the index of the list element
53                                 * to extract for comparison.  If -index
54                                 * wasn't specified, this is -1. */
55    Tcl_Interp *interp;         /* The interpreter in which the sortis
56                                 * being done. */
57    int resultCode;             /* Completion code for the lsort command.
58                                 * If an error occurs during the sort this
59                                 * is changed from TCL_OK to  TCL_ERROR. */
60} SortInfo;
61
62/*
63 * The "sortMode" field of the SortInfo structure can take on any of the
64 * following values.
65 */
66
67#define SORTMODE_ASCII      0
68#define SORTMODE_INTEGER    1
69#define SORTMODE_REAL       2
70#define SORTMODE_COMMAND    3
71#define SORTMODE_DICTIONARY 4
72
73/*
74 * Forward declarations for procedures defined in this file:
75 */
76
77static void             AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
78                            Tcl_Obj *listPtr, char *pattern,
79                            int includeLinks));
80static int              DictionaryCompare _ANSI_ARGS_((char *left,
81                            char *right));
82static int              InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
83                            Tcl_Interp *interp, int objc,
84                            Tcl_Obj *CONST objv[]));
85static int              InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
86                            Tcl_Interp *interp, int objc,
87                            Tcl_Obj *CONST objv[]));
88static int              InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
89                            Tcl_Interp *interp, int objc,
90                            Tcl_Obj *CONST objv[]));
91static int              InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
92                            Tcl_Interp *interp, int objc,
93                            Tcl_Obj *CONST objv[]));
94static int              InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
95                            Tcl_Interp *interp, int objc,
96                            Tcl_Obj *CONST objv[]));
97static int              InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
98                            Tcl_Interp *interp, int objc,
99                            Tcl_Obj *CONST objv[]));
100static int              InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
101                            Tcl_Interp *interp, int objc,
102                            Tcl_Obj *CONST objv[]));
103static int              InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
104                            Tcl_Interp *interp, int objc,
105                            Tcl_Obj *CONST objv[]));
106static int              InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
107                            Tcl_Interp *interp, int objc,
108                            Tcl_Obj *CONST objv[]));
109static int              InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
110                            Tcl_Interp *interp, int objc,
111                            Tcl_Obj *CONST objv[]));
112static int              InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
113                            Tcl_Interp *interp, int objc,
114                            Tcl_Obj *CONST objv[]));
115static int              InfoNameOfExecutableCmd _ANSI_ARGS_((
116                            ClientData dummy, Tcl_Interp *interp, int objc,
117                            Tcl_Obj *CONST objv[]));
118static int              InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
119                            Tcl_Interp *interp, int objc,
120                            Tcl_Obj *CONST objv[]));
121static int              InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
122                            Tcl_Interp *interp, int objc,
123                            Tcl_Obj *CONST objv[]));
124static int              InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
125                            Tcl_Interp *interp, int objc,
126                            Tcl_Obj *CONST objv[]));
127static int              InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
128                            Tcl_Interp *interp, int objc,
129                            Tcl_Obj *CONST objv[]));
130static int              InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
131                            Tcl_Interp *interp, int objc,
132                            Tcl_Obj *CONST objv[]));
133static int              InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
134                            Tcl_Interp *interp, int objc,
135                            Tcl_Obj *CONST objv[]));
136static SortElement *    MergeSort _ANSI_ARGS_((SortElement *headPt,
137                            SortInfo *infoPtr));
138static SortElement *    MergeLists _ANSI_ARGS_((SortElement *leftPtr,
139                            SortElement *rightPtr, SortInfo *infoPtr));
140static int              SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
141                            Tcl_Obj *second, SortInfo *infoPtr));
142
143/*
144 *----------------------------------------------------------------------
145 *
146 * Tcl_IfCmd --
147 *
148 *      This procedure is invoked to process the "if" Tcl command.
149 *      See the user documentation for details on what it does.
150 *
151 *      With the bytecode compiler, this procedure is only called when
152 *      a command name is computed at runtime, and is "if" or the name
153 *      to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
154 *
155 * Results:
156 *      A standard Tcl result.
157 *
158 * Side effects:
159 *      See the user documentation.
160 *
161 *----------------------------------------------------------------------
162 */
163
164        /* ARGSUSED */
165int
166Tcl_IfCmd(dummy, interp, argc, argv)
167    ClientData dummy;                   /* Not used. */
168    Tcl_Interp *interp;                 /* Current interpreter. */
169    int argc;                           /* Number of arguments. */
170    char **argv;                        /* Argument strings. */
171{
172    int i, result, value;
173
174    i = 1;
175    while (1) {
176        /*
177         * At this point in the loop, argv and argc refer to an expression
178         * to test, either for the main expression or an expression
179         * following an "elseif".  The arguments after the expression must
180         * be "then" (optional) and a script to execute if the expression is
181         * true.
182         */
183
184        if (i >= argc) {
185            Tcl_AppendResult(interp, "wrong # args: no expression after \"",
186                    argv[i-1], "\" argument", (char *) NULL);
187            return TCL_ERROR;
188        }
189        result = Tcl_ExprBoolean(interp, argv[i], &value);
190        if (result != TCL_OK) {
191            return result;
192        }
193        i++;
194        if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
195            i++;
196        }
197        if (i >= argc) {
198            Tcl_AppendResult(interp, "wrong # args: no script following \"",
199                    argv[i-1], "\" argument", (char *) NULL);
200            return TCL_ERROR;
201        }
202        if (value) {
203            return Tcl_Eval(interp, argv[i]);
204        }
205       
206        /*
207         * The expression evaluated to false.  Skip the command, then
208         * see if there is an "else" or "elseif" clause.
209         */
210
211        i++;
212        if (i >= argc) {
213            return TCL_OK;
214        }
215        if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
216            i++;
217            continue;
218        }
219        break;
220    }
221
222    /*
223     * Couldn't find a "then" or "elseif" clause to execute.  Check now
224     * for an "else" clause.  We know that there's at least one more
225     * argument when we get here.
226     */
227
228    if (strcmp(argv[i], "else") == 0) {
229        i++;
230        if (i >= argc) {
231            Tcl_AppendResult(interp,
232                    "wrong # args: no script following \"else\" argument",
233                    (char *) NULL);
234            return TCL_ERROR;
235        }
236    }
237    return Tcl_Eval(interp, argv[i]);
238}
239
240/*
241 *----------------------------------------------------------------------
242 *
243 * Tcl_IncrCmd --
244 *
245 *      This procedure is invoked to process the "incr" Tcl command.
246 *      See the user documentation for details on what it does.
247 *
248 *      With the bytecode compiler, this procedure is only called when
249 *      a command name is computed at runtime, and is "incr" or the name
250 *      to which "incr" was renamed: e.g., "set z incr; $z i -1"
251 *
252 * Results:
253 *      A standard Tcl result.
254 *
255 * Side effects:
256 *      See the user documentation.
257 *
258 *----------------------------------------------------------------------
259 */
260
261    /* ARGSUSED */
262int
263Tcl_IncrCmd(dummy, interp, argc, argv)
264    ClientData dummy;                   /* Not used. */
265    Tcl_Interp *interp;                 /* Current interpreter. */
266    int argc;                           /* Number of arguments. */
267    char **argv;                        /* Argument strings. */
268{
269    int value;
270    char *oldString, *result;
271    char newString[30];
272
273    if ((argc != 2) && (argc != 3)) {
274        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
275                " varName ?increment?\"", (char *) NULL);
276        return TCL_ERROR;
277    }
278
279    oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
280    if (oldString == NULL) {
281        return TCL_ERROR;
282    }
283    if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
284        Tcl_AddErrorInfo(interp,
285                "\n    (reading value of variable to increment)");
286        return TCL_ERROR;
287    }
288    if (argc == 2) {
289        value += 1;
290    } else {
291        int increment;
292
293        if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
294            Tcl_AddErrorInfo(interp,
295                    "\n    (reading increment)");
296            return TCL_ERROR;
297        }
298        value += increment;
299    }
300    TclFormatInt(newString, value);
301    result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
302    if (result == NULL) {
303        return TCL_ERROR;
304    }
305
306    /*
307     * Copy the result since the variable's value might change.
308     */
309   
310    Tcl_SetResult(interp, result, TCL_VOLATILE);
311    return TCL_OK; 
312}
313
314/*
315 *----------------------------------------------------------------------
316 *
317 * Tcl_InfoObjCmd --
318 *
319 *      This procedure is invoked to process the "info" Tcl command.
320 *      See the user documentation for details on what it does.
321 *
322 * Results:
323 *      A standard Tcl result.
324 *
325 * Side effects:
326 *      See the user documentation.
327 *
328 *----------------------------------------------------------------------
329 */
330
331        /* ARGSUSED */
332int
333Tcl_InfoObjCmd(clientData, interp, objc, objv)
334    ClientData clientData;      /* Arbitrary value passed to the command. */
335    Tcl_Interp *interp;         /* Current interpreter. */
336    int objc;                   /* Number of arguments. */
337    Tcl_Obj *CONST objv[];      /* Argument objects. */
338{
339    static char *subCmds[] = {
340       "args", "body", "cmdcount", "commands",
341             "complete", "default", "exists", "globals",
342             "level", "library",
343             "locals", "nameofexecutable", "patchlevel", "procs",
344             "script", "sharedlibextension", "tclversion", "vars",
345             (char *) NULL};
346    enum ISubCmdIdx {
347            IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
348            ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx,
349      ILevelIdx, ILibraryIdx,
350            ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
351            IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
352    } index;
353    int result;
354
355    if (objc < 2) {
356        Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
357        return TCL_ERROR;
358    }
359   
360    result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
361            (int *) &index);
362    if (result != TCL_OK) {
363        return result;
364    }
365
366    switch (index) {
367        case IArgsIdx:
368            result = InfoArgsCmd(clientData, interp, objc, objv);
369            break;
370        case IBodyIdx:
371            result = InfoBodyCmd(clientData, interp, objc, objv);
372            break;
373        case ICmdCountIdx:
374            result = InfoCmdCountCmd(clientData, interp, objc, objv);
375            break;
376        case ICommandsIdx:
377            result = InfoCommandsCmd(clientData, interp, objc, objv);
378            break;
379        case ICompleteIdx:
380            result = InfoCompleteCmd(clientData, interp, objc, objv);
381            break;
382        case IDefaultIdx:
383            result = InfoDefaultCmd(clientData, interp, objc, objv);
384            break;
385        case IExistsIdx:
386            result = InfoExistsCmd(clientData, interp, objc, objv);
387            break;
388        case IGlobalsIdx:
389            result = InfoGlobalsCmd(clientData, interp, objc, objv);
390            break;
391        case ILevelIdx:
392            result = InfoLevelCmd(clientData, interp, objc, objv);
393            break;
394        case ILibraryIdx:
395            result = InfoLibraryCmd(clientData, interp, objc, objv);
396            break;
397        case ILocalsIdx:
398            result = InfoLocalsCmd(clientData, interp, objc, objv);
399            break;
400        case INameOfExecutableIdx:
401            result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
402            break;
403        case IPatchLevelIdx:
404            result = InfoPatchLevelCmd(clientData, interp, objc, objv);
405            break;
406        case IProcsIdx:
407            result = InfoProcsCmd(clientData, interp, objc, objv);
408            break;
409        case IScriptIdx:
410            result = InfoScriptCmd(clientData, interp, objc, objv);
411            break;
412        case ISharedLibExtensionIdx:
413            result = InfoSharedlibCmd(clientData, interp, objc, objv);
414            break;
415        case ITclVersionIdx:
416            result = InfoTclVersionCmd(clientData, interp, objc, objv);
417            break;
418        case IVarsIdx:
419            result = InfoVarsCmd(clientData, interp, objc, objv);
420            break;
421    }
422    return result;
423}
424
425/*
426 *----------------------------------------------------------------------
427 *
428 * InfoArgsCmd --
429 *
430 *      Called to implement the "info args" command that returns the
431 *      argument list for a procedure. Handles the following syntax:
432 *
433 *          info args procName
434 *
435 * Results:
436 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
437 *
438 * Side effects:
439 *      Returns a result in the interpreter's result object. If there is
440 *      an error, the result is an error message.
441 *
442 *----------------------------------------------------------------------
443 */
444
445static int
446InfoArgsCmd(dummy, interp, objc, objv)
447    ClientData dummy;           /* Not used. */
448    Tcl_Interp *interp;         /* Current interpreter. */
449    int objc;                   /* Number of arguments. */
450    Tcl_Obj *CONST objv[];      /* Argument objects. */
451{
452    register Interp *iPtr = (Interp *) interp;
453    char *name;
454    Proc *procPtr;
455    CompiledLocal *localPtr;
456    Tcl_Obj *listObjPtr;
457
458    if (objc != 3) {
459        Tcl_WrongNumArgs(interp, 2, objv, "procname");
460        return TCL_ERROR;
461    }
462
463    name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
464    procPtr = TclFindProc(iPtr, name);
465    if (procPtr == NULL) {
466        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
467                "\"", name, "\" isn't a procedure", (char *) NULL);
468        return TCL_ERROR;
469    }
470
471    /*
472     * Build a return list containing the arguments.
473     */
474   
475    listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
476    for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
477            localPtr = localPtr->nextPtr) {
478        if (TclIsVarArgument(localPtr)) {
479            Tcl_ListObjAppendElement(interp, listObjPtr,
480                    Tcl_NewStringObj(localPtr->name, -1));
481        }
482    }
483    Tcl_SetObjResult(interp, listObjPtr);
484    return TCL_OK;
485}
486
487/*
488 *----------------------------------------------------------------------
489 *
490 * InfoBodyCmd --
491 *
492 *      Called to implement the "info body" command that returns the body
493 *      for a procedure. Handles the following syntax:
494 *
495 *          info body procName
496 *
497 * Results:
498 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
499 *
500 * Side effects:
501 *      Returns a result in the interpreter's result object. If there is
502 *      an error, the result is an error message.
503 *
504 *----------------------------------------------------------------------
505 */
506
507static int
508InfoBodyCmd(dummy, interp, objc, objv)
509    ClientData dummy;           /* Not used. */
510    Tcl_Interp *interp;         /* Current interpreter. */
511    int objc;                   /* Number of arguments. */
512    Tcl_Obj *CONST objv[];      /* Argument objects. */
513{
514    register Interp *iPtr = (Interp *) interp;
515    char *name;
516    Proc *procPtr;
517    Tcl_Obj *bodyPtr, *resultPtr;
518   
519    if (objc != 3) {
520        Tcl_WrongNumArgs(interp, 2, objv, "procname");
521        return TCL_ERROR;
522    }
523
524    name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
525    procPtr = TclFindProc(iPtr, name);
526    if (procPtr == NULL) {
527        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
528                "\"", name, "\" isn't a procedure", (char *) NULL);
529        return TCL_ERROR;
530    }
531
532    /*
533     * we need to check if the body from this procedure had been generated
534     * from a precompiled body. If that is the case, then the bodyPtr's
535     * string representation is bogus, since sources are not available.
536     * In order to make sure that later manipulations of the object do not
537     * invalidate the internal representation, we make a copy of the string
538     * representation and return that one, instead.
539     */
540
541    bodyPtr = procPtr->bodyPtr;
542    resultPtr = bodyPtr;
543    if (bodyPtr->typePtr == &tclByteCodeType) {
544        ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
545
546        if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
547            resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
548        }
549    }
550   
551    Tcl_SetObjResult(interp, resultPtr);
552    return TCL_OK;
553}
554
555/*
556 *----------------------------------------------------------------------
557 *
558 * InfoCmdCountCmd --
559 *
560 *      Called to implement the "info cmdcount" command that returns the
561 *      number of commands that have been executed. Handles the following
562 *      syntax:
563 *
564 *          info cmdcount
565 *
566 * Results:
567 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
568 *
569 * Side effects:
570 *      Returns a result in the interpreter's result object. If there is
571 *      an error, the result is an error message.
572 *
573 *----------------------------------------------------------------------
574 */
575
576static int
577InfoCmdCountCmd(dummy, interp, objc, objv)
578    ClientData dummy;           /* Not used. */
579    Tcl_Interp *interp;         /* Current interpreter. */
580    int objc;                   /* Number of arguments. */
581    Tcl_Obj *CONST objv[];      /* Argument objects. */
582{
583    Interp *iPtr = (Interp *) interp;
584   
585    if (objc != 2) {
586        Tcl_WrongNumArgs(interp, 2, objv, NULL);
587        return TCL_ERROR;
588    }
589
590    Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
591    return TCL_OK;
592}
593
594/*
595 *----------------------------------------------------------------------
596 *
597 * InfoCommandsCmd --
598 *
599 *      Called to implement the "info commands" command that returns the
600 *      list of commands in the interpreter that match an optional pattern.
601 *      The pattern, if any, consists of an optional sequence of namespace
602 *      names separated by "::" qualifiers, which is followed by a
603 *      glob-style pattern that restricts which commands are returned.
604 *      Handles the following syntax:
605 *
606 *          info commands ?pattern?
607 *
608 * Results:
609 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
610 *
611 * Side effects:
612 *      Returns a result in the interpreter's result object. If there is
613 *      an error, the result is an error message.
614 *
615 *----------------------------------------------------------------------
616 */
617
618static int
619InfoCommandsCmd(dummy, interp, objc, objv)
620    ClientData dummy;           /* Not used. */
621    Tcl_Interp *interp;         /* Current interpreter. */
622    int objc;                   /* Number of arguments. */
623    Tcl_Obj *CONST objv[];      /* Argument objects. */
624{
625    char *cmdName, *pattern, *simplePattern;
626    register Tcl_HashEntry *entryPtr;
627    Tcl_HashSearch search;
628    Namespace *nsPtr;
629    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
630    Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);
631    Tcl_Obj *listPtr, *elemObjPtr;
632    int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */
633    Tcl_Command cmd;
634
635    /*
636     * Get the pattern and find the "effective namespace" in which to
637     * list commands.
638     */
639
640    if (objc == 2) {
641        simplePattern = NULL;
642        nsPtr = currNsPtr;
643        specificNsInPattern = 0;
644    } else if (objc == 3) {
645        /*
646         * From the pattern, get the effective namespace and the simple
647         * pattern (no namespace qualifiers or ::'s) at the end. If an
648         * error was found while parsing the pattern, return it. Otherwise,
649         * if the namespace wasn't found, just leave nsPtr NULL: we will
650         * return an empty list since no commands there can be found.
651         */
652
653        Namespace *dummy1NsPtr, *dummy2NsPtr;
654       
655        pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
656       TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
657           /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
658
659        if (nsPtr != NULL) {    /* we successfully found the pattern's ns */
660            specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
661        }
662    } else {
663        Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
664        return TCL_ERROR;
665    }
666
667    /*
668     * Scan through the effective namespace's command table and create a
669     * list with all commands that match the pattern. If a specific
670     * namespace was requested in the pattern, qualify the command names
671     * with the namespace name.
672     */
673
674    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
675
676    if (nsPtr != NULL) {
677        entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
678        while (entryPtr != NULL) {
679            cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
680            if ((simplePattern == NULL)
681                    || Tcl_StringMatch(cmdName, simplePattern)) {
682                if (specificNsInPattern) {
683                    cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
684                    elemObjPtr = Tcl_NewObj();
685                    Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
686                } else {
687                    elemObjPtr = Tcl_NewStringObj(cmdName, -1);
688                }
689                Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
690            }
691            entryPtr = Tcl_NextHashEntry(&search);
692        }
693
694        /*
695         * If the effective namespace isn't the global :: namespace, and a
696         * specific namespace wasn't requested in the pattern, then add in
697         * all global :: commands that match the simple pattern. Of course,
698         * we add in only those commands that aren't hidden by a command in
699         * the effective namespace.
700         */
701       
702        if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
703            entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
704            while (entryPtr != NULL) {
705                cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
706                if ((simplePattern == NULL)
707                        || Tcl_StringMatch(cmdName, simplePattern)) {
708                    if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
709                        Tcl_ListObjAppendElement(interp, listPtr,
710                                Tcl_NewStringObj(cmdName, -1));
711                    }
712                }
713                entryPtr = Tcl_NextHashEntry(&search);
714            }
715        }
716    }
717   
718    Tcl_SetObjResult(interp, listPtr);
719    return TCL_OK;
720}
721
722/*
723 *----------------------------------------------------------------------
724 *
725 * InfoCompleteCmd --
726 *
727 *      Called to implement the "info complete" command that determines
728 *      whether a string is a complete Tcl command. Handles the following
729 *      syntax:
730 *
731 *          info complete command
732 *
733 * Results:
734 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
735 *
736 * Side effects:
737 *      Returns a result in the interpreter's result object. If there is
738 *      an error, the result is an error message.
739 *
740 *----------------------------------------------------------------------
741 */
742
743static int
744InfoCompleteCmd(dummy, interp, objc, objv)
745    ClientData dummy;           /* Not used. */
746    Tcl_Interp *interp;         /* Current interpreter. */
747    int objc;                   /* Number of arguments. */
748    Tcl_Obj *CONST objv[];      /* Argument objects. */
749{
750    if (objc != 3) {
751        Tcl_WrongNumArgs(interp, 2, objv, "command");
752        return TCL_ERROR;
753    }
754
755    if (TclObjCommandComplete(objv[2])) {
756        Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
757    } else {
758        Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
759    }
760
761    return TCL_OK;
762}
763
764/*
765 *----------------------------------------------------------------------
766 *
767 * InfoDefaultCmd --
768 *
769 *      Called to implement the "info default" command that returns the
770 *      default value for a procedure argument. Handles the following
771 *      syntax:
772 *
773 *          info default procName arg varName
774 *
775 * Results:
776 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
777 *
778 * Side effects:
779 *      Returns a result in the interpreter's result object. If there is
780 *      an error, the result is an error message.
781 *
782 *----------------------------------------------------------------------
783 */
784
785static int
786InfoDefaultCmd(dummy, interp, objc, objv)
787    ClientData dummy;           /* Not used. */
788    Tcl_Interp *interp;         /* Current interpreter. */
789    int objc;                   /* Number of arguments. */
790    Tcl_Obj *CONST objv[];      /* Argument objects. */
791{
792    Interp *iPtr = (Interp *) interp;
793    char *procName, *argName, *varName;
794    Proc *procPtr;
795    CompiledLocal *localPtr;
796    Tcl_Obj *valueObjPtr;
797
798    if (objc != 5) {
799        Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
800        return TCL_ERROR;
801    }
802
803    procName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
804    argName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
805
806    procPtr = TclFindProc(iPtr, procName);
807    if (procPtr == NULL) {
808        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
809                "\"", procName, "\" isn't a procedure", (char *) NULL);
810        return TCL_ERROR;
811    }
812
813    for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
814            localPtr = localPtr->nextPtr) {
815        if (TclIsVarArgument(localPtr)
816                && (strcmp(argName, localPtr->name) == 0)) {
817            if (localPtr->defValuePtr != NULL) {
818                valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
819                        localPtr->defValuePtr, 0);
820                if (valueObjPtr == NULL) {
821                    defStoreError:
822                    varName = Tcl_GetStringFromObj(objv[4], (int *) NULL);
823                    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
824                            "couldn't store default value in variable \"",
825                            varName, "\"", (char *) NULL);
826                    return TCL_ERROR;
827                }
828                Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
829            } else {
830                Tcl_Obj *nullObjPtr = Tcl_NewObj();
831                valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
832                    nullObjPtr, 0);
833                if (valueObjPtr == NULL) {
834                    Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
835                    goto defStoreError;
836                }
837                Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
838            }
839            return TCL_OK;
840        }
841    }
842
843    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
844            "procedure \"", procName, "\" doesn't have an argument \"",
845            argName, "\"", (char *) NULL);
846    return TCL_ERROR;
847}
848
849/*
850 *----------------------------------------------------------------------
851 *
852 * InfoExistsCmd --
853 *
854 *      Called to implement the "info exists" command that determines
855 *      whether a variable exists. Handles the following syntax:
856 *
857 *          info exists varName
858 *
859 * Results:
860 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
861 *
862 * Side effects:
863 *      Returns a result in the interpreter's result object. If there is
864 *      an error, the result is an error message.
865 *
866 *----------------------------------------------------------------------
867 */
868
869static int
870InfoExistsCmd(dummy, interp, objc, objv)
871    ClientData dummy;           /* Not used. */
872    Tcl_Interp *interp;         /* Current interpreter. */
873    int objc;                   /* Number of arguments. */
874    Tcl_Obj *CONST objv[];      /* Argument objects. */
875{
876    char *varName;
877    Var *varPtr, *arrayPtr;
878
879    if (objc != 3) {
880        Tcl_WrongNumArgs(interp, 2, objv, "varName");
881        return TCL_ERROR;
882    }
883
884    varName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
885    varPtr = TclLookupVar(interp, varName, (char *) NULL,
886            TCL_PARSE_PART1, "access",
887            /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
888    if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
889        Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
890    } else {
891        Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
892    }
893    return TCL_OK;
894}
895
896/*
897 *----------------------------------------------------------------------
898 *
899 * InfoGlobalsCmd --
900 *
901 *      Called to implement the "info globals" command that returns the list
902 *      of global variables matching an optional pattern. Handles the
903 *      following syntax:
904 *
905 *          info globals ?pattern?
906 *
907 * Results:
908 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
909 *
910 * Side effects:
911 *      Returns a result in the interpreter's result object. If there is
912 *      an error, the result is an error message.
913 *
914 *----------------------------------------------------------------------
915 */
916
917static int
918InfoGlobalsCmd(dummy, interp, objc, objv)
919    ClientData dummy;           /* Not used. */
920    Tcl_Interp *interp;         /* Current interpreter. */
921    int objc;                   /* Number of arguments. */
922    Tcl_Obj *CONST objv[];      /* Argument objects. */
923{
924    char *varName, *pattern;
925    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
926    register Tcl_HashEntry *entryPtr;
927    Tcl_HashSearch search;
928    Var *varPtr;
929    Tcl_Obj *listPtr;
930
931    if (objc == 2) {
932        pattern = NULL;
933    } else if (objc == 3) {
934        pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
935    } else {
936        Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
937        return TCL_ERROR;
938    }
939
940    /*
941     * Scan through the global :: namespace's variable table and create a
942     * list of all global variables that match the pattern.
943     */
944   
945    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
946    for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
947            entryPtr != NULL;
948            entryPtr = Tcl_NextHashEntry(&search)) {
949        varPtr = (Var *) Tcl_GetHashValue(entryPtr);
950        if (TclIsVarUndefined(varPtr)) {
951            continue;
952        }
953        varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
954        if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
955            Tcl_ListObjAppendElement(interp, listPtr,
956                    Tcl_NewStringObj(varName, -1));
957        }
958    }
959    Tcl_SetObjResult(interp, listPtr);
960    return TCL_OK;
961}
962
963/*
964 *----------------------------------------------------------------------
965 *
966 * InfoLevelCmd --
967 *
968 *      Called to implement the "info level" command that returns
969 *      information about the call stack. Handles the following syntax:
970 *
971 *          info level ?number?
972 *
973 * Results:
974 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
975 *
976 * Side effects:
977 *      Returns a result in the interpreter's result object. If there is
978 *      an error, the result is an error message.
979 *
980 *----------------------------------------------------------------------
981 */
982
983static int
984InfoLevelCmd(dummy, interp, objc, objv)
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    Interp *iPtr = (Interp *) interp;
991    int level;
992    CallFrame *framePtr;
993    Tcl_Obj *listPtr;
994
995    if (objc == 2) {            /* just "info level" */
996        if (iPtr->varFramePtr == NULL) {
997            Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
998        } else {
999            Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
1000        }
1001        return TCL_OK;
1002    } else if (objc == 3) {
1003        if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
1004            return TCL_ERROR;
1005        }
1006        if (level <= 0) {
1007            if (iPtr->varFramePtr == NULL) {
1008                levelError:
1009                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1010                        "bad level \"",
1011                        Tcl_GetStringFromObj(objv[2], (int *) NULL),
1012                        "\"", (char *) NULL);
1013                return TCL_ERROR;
1014            }
1015            level += iPtr->varFramePtr->level;
1016        }
1017        for (framePtr = iPtr->varFramePtr;  framePtr != NULL;
1018                framePtr = framePtr->callerVarPtr) {
1019            if (framePtr->level == level) {
1020                break;
1021            }
1022        }
1023        if (framePtr == NULL) {
1024            goto levelError;
1025        }
1026
1027        listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
1028        Tcl_SetObjResult(interp, listPtr);
1029        return TCL_OK;
1030    }
1031
1032    Tcl_WrongNumArgs(interp, 2, objv, "?number?");
1033    return TCL_ERROR;
1034}
1035
1036/*
1037 *----------------------------------------------------------------------
1038 *
1039 * InfoLibraryCmd --
1040 *
1041 *      Called to implement the "info library" command that returns the
1042 *      library directory for the Tcl installation. Handles the following
1043 *      syntax:
1044 *
1045 *          info library
1046 *
1047 * Results:
1048 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
1049 *
1050 * Side effects:
1051 *      Returns a result in the interpreter's result object. If there is
1052 *      an error, the result is an error message.
1053 *
1054 *----------------------------------------------------------------------
1055 */
1056
1057static int
1058InfoLibraryCmd(dummy, interp, objc, objv)
1059    ClientData dummy;           /* Not used. */
1060    Tcl_Interp *interp;         /* Current interpreter. */
1061    int objc;                   /* Number of arguments. */
1062    Tcl_Obj *CONST objv[];      /* Argument objects. */
1063{
1064    char *libDirName;
1065
1066    if (objc != 2) {
1067        Tcl_WrongNumArgs(interp, 2, objv, NULL);
1068        return TCL_ERROR;
1069    }
1070
1071    libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
1072    if (libDirName != NULL) {
1073        Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
1074        return TCL_OK;
1075    }
1076    Tcl_SetStringObj(Tcl_GetObjResult(interp), 
1077            "no library has been specified for Tcl", -1);
1078    return TCL_ERROR;
1079}
1080
1081/*
1082 *----------------------------------------------------------------------
1083 *
1084 * InfoLocalsCmd --
1085 *
1086 *      Called to implement the "info locals" command to return a list of
1087 *      local variables that match an optional pattern. Handles the
1088 *      following syntax:
1089 *
1090 *          info locals ?pattern?
1091 *
1092 * Results:
1093 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
1094 *
1095 * Side effects:
1096 *      Returns a result in the interpreter's result object. If there is
1097 *      an error, the result is an error message.
1098 *
1099 *----------------------------------------------------------------------
1100 */
1101
1102static int
1103InfoLocalsCmd(dummy, interp, objc, objv)
1104    ClientData dummy;           /* Not used. */
1105    Tcl_Interp *interp;         /* Current interpreter. */
1106    int objc;                   /* Number of arguments. */
1107    Tcl_Obj *CONST objv[];      /* Argument objects. */
1108{
1109    Interp *iPtr = (Interp *) interp;
1110    char *pattern;
1111    Tcl_Obj *listPtr;
1112
1113    if (objc == 2) {
1114        pattern = NULL;
1115    } else if (objc == 3) {
1116        pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
1117    } else {
1118        Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1119        return TCL_ERROR;
1120    }
1121   
1122    if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) {
1123        return TCL_OK;
1124    }
1125
1126    /*
1127     * Return a list containing names of first the compiled locals (i.e. the
1128     * ones stored in the call frame), then the variables in the local hash
1129     * table (if one exists).
1130     */
1131   
1132    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1133    AppendLocals(interp, listPtr, pattern, 0);
1134    Tcl_SetObjResult(interp, listPtr);
1135    return TCL_OK;
1136}
1137
1138/*
1139 *----------------------------------------------------------------------
1140 *
1141 * AppendLocals --
1142 *
1143 *      Append the local variables for the current frame to the
1144 *      specified list object.
1145 *
1146 * Results:
1147 *      None.
1148 *
1149 * Side effects:
1150 *      None.
1151 *
1152 *----------------------------------------------------------------------
1153 */
1154
1155static void
1156AppendLocals(interp, listPtr, pattern, includeLinks)
1157    Tcl_Interp *interp;         /* Current interpreter. */
1158    Tcl_Obj *listPtr;           /* List object to append names to. */
1159    char *pattern;              /* Pattern to match against. */
1160    int includeLinks;           /* 1 if upvars should be included, else 0. */
1161{
1162    Interp *iPtr = (Interp *) interp;
1163    CompiledLocal *localPtr;
1164    Var *varPtr;
1165    int i, localVarCt;
1166    char *varName;
1167    Tcl_HashTable *localVarTablePtr;
1168    register Tcl_HashEntry *entryPtr;
1169    Tcl_HashSearch search;
1170
1171    localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
1172    localVarCt = iPtr->varFramePtr->numCompiledLocals;
1173    varPtr = iPtr->varFramePtr->compiledLocals;
1174    localVarTablePtr = iPtr->varFramePtr->varTablePtr;
1175
1176    for (i = 0; i < localVarCt; i++) {
1177        /*
1178         * Skip nameless (temporary) variables and undefined variables
1179         */
1180
1181        if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) {
1182            varName = varPtr->name;
1183            if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
1184                Tcl_ListObjAppendElement(interp, listPtr,
1185                        Tcl_NewStringObj(varName, -1));
1186            }
1187        }
1188        varPtr++;
1189        localPtr = localPtr->nextPtr;
1190    }
1191   
1192    if (localVarTablePtr != NULL) {
1193        for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
1194                entryPtr != NULL;
1195                entryPtr = Tcl_NextHashEntry(&search)) {
1196            varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1197            if (!TclIsVarUndefined(varPtr)
1198                    && (includeLinks || !TclIsVarLink(varPtr))) {
1199                varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
1200                if ((pattern == NULL)
1201                        || Tcl_StringMatch(varName, pattern)) {
1202                    Tcl_ListObjAppendElement(interp, listPtr,
1203                            Tcl_NewStringObj(varName, -1));
1204                }
1205            }
1206        }
1207    }
1208}
1209
1210/*
1211 *----------------------------------------------------------------------
1212 *
1213 * InfoNameOfExecutableCmd --
1214 *
1215 *      Called to implement the "info nameofexecutable" command that returns
1216 *      the name of the binary file running this application. Handles the
1217 *      following syntax:
1218 *
1219 *          info nameofexecutable
1220 *
1221 * Results:
1222 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
1223 *
1224 * Side effects:
1225 *      Returns a result in the interpreter's result object. If there is
1226 *      an error, the result is an error message.
1227 *
1228 *----------------------------------------------------------------------
1229 */
1230
1231static int
1232InfoNameOfExecutableCmd(dummy, interp, objc, objv)
1233    ClientData dummy;           /* Not used. */
1234    Tcl_Interp *interp;         /* Current interpreter. */
1235    int objc;                   /* Number of arguments. */
1236    Tcl_Obj *CONST objv[];      /* Argument objects. */
1237{
1238    CONST char *nameOfExecutable;
1239
1240    if (objc != 2) {
1241        Tcl_WrongNumArgs(interp, 2, objv, NULL);
1242        return TCL_ERROR;
1243    }
1244
1245    nameOfExecutable = Tcl_GetNameOfExecutable();
1246   
1247    if (nameOfExecutable != NULL) {
1248        Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *)nameOfExecutable, -1);
1249    }
1250    return TCL_OK;
1251}
1252
1253/*
1254 *----------------------------------------------------------------------
1255 *
1256 * InfoPatchLevelCmd --
1257 *
1258 *      Called to implement the "info patchlevel" command that returns the
1259 *      default value for an argument to a procedure. Handles the following
1260 *      syntax:
1261 *
1262 *          info patchlevel
1263 *
1264 * Results:
1265 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
1266 *
1267 * Side effects:
1268 *      Returns a result in the interpreter's result object. If there is
1269 *      an error, the result is an error message.
1270 *
1271 *----------------------------------------------------------------------
1272 */
1273
1274static int
1275InfoPatchLevelCmd(dummy, interp, objc, objv)
1276    ClientData dummy;           /* Not used. */
1277    Tcl_Interp *interp;         /* Current interpreter. */
1278    int objc;                   /* Number of arguments. */
1279    Tcl_Obj *CONST objv[];      /* Argument objects. */
1280{
1281    char *patchlevel;
1282
1283    if (objc != 2) {
1284        Tcl_WrongNumArgs(interp, 2, objv, NULL);
1285        return TCL_ERROR;
1286    }
1287
1288    patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
1289            (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
1290    if (patchlevel != NULL) {
1291        Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
1292        return TCL_OK;
1293    }
1294    return TCL_ERROR;
1295}
1296
1297/*
1298 *----------------------------------------------------------------------
1299 *
1300 * InfoProcsCmd --
1301 *
1302 *      Called to implement the "info procs" command that returns the
1303 *      procedures in the current namespace that match an optional pattern.
1304 *      Handles the following syntax:
1305 *
1306 *          info procs ?pattern?
1307 *
1308 * Results:
1309 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
1310 *
1311 * Side effects:
1312 *      Returns a result in the interpreter's result object. If there is
1313 *      an error, the result is an error message.
1314 *
1315 *----------------------------------------------------------------------
1316 */
1317
1318static int
1319InfoProcsCmd(dummy, interp, objc, objv)
1320    ClientData dummy;           /* Not used. */
1321    Tcl_Interp *interp;         /* Current interpreter. */
1322    int objc;                   /* Number of arguments. */
1323    Tcl_Obj *CONST objv[];      /* Argument objects. */
1324{
1325    char *cmdName, *pattern;
1326    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1327    register Tcl_HashEntry *entryPtr;
1328    Tcl_HashSearch search;
1329    Command *cmdPtr;
1330    Tcl_Obj *listPtr;
1331
1332    if (objc == 2) {
1333        pattern = NULL;
1334    } else if (objc == 3) {
1335        pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
1336    } else {
1337        Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1338        return TCL_ERROR;
1339    }
1340
1341    /*
1342     * Scan through the current namespace's command table and return a list
1343     * of all procs that match the pattern.
1344     */
1345   
1346    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1347    for (entryPtr = Tcl_FirstHashEntry(&currNsPtr->cmdTable, &search);
1348            entryPtr != NULL;
1349            entryPtr = Tcl_NextHashEntry(&search)) {
1350        cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr);
1351        cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
1352        if (TclIsProc(cmdPtr)) {
1353            if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) {
1354                Tcl_ListObjAppendElement(interp, listPtr,
1355                        Tcl_NewStringObj(cmdName, -1));
1356            }
1357        }
1358    }
1359    Tcl_SetObjResult(interp, listPtr);
1360    return TCL_OK;
1361}
1362
1363/*
1364 *----------------------------------------------------------------------
1365 *
1366 * InfoScriptCmd --
1367 *
1368 *      Called to implement the "info script" command that returns the
1369 *      script file that is currently being evaluated. Handles the
1370 *      following syntax:
1371 *
1372 *          info script
1373 *
1374 * Results:
1375 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
1376 *
1377 * Side effects:
1378 *      Returns a result in the interpreter's result object. If there is
1379 *      an error, the result is an error message.
1380 *
1381 *----------------------------------------------------------------------
1382 */
1383
1384static int
1385InfoScriptCmd(dummy, interp, objc, objv)
1386    ClientData dummy;           /* Not used. */
1387    Tcl_Interp *interp;         /* Current interpreter. */
1388    int objc;                   /* Number of arguments. */
1389    Tcl_Obj *CONST objv[];      /* Argument objects. */
1390{
1391    Interp *iPtr = (Interp *) interp;
1392    if (objc != 2) {
1393        Tcl_WrongNumArgs(interp, 2, objv, NULL);
1394        return TCL_ERROR;
1395    }
1396
1397    if (iPtr->scriptFile != NULL) {
1398        Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);
1399    }
1400    return TCL_OK;
1401}
1402
1403/*
1404 *----------------------------------------------------------------------
1405 *
1406 * InfoSharedlibCmd --
1407 *
1408 *      Called to implement the "info sharedlibextension" command that
1409 *      returns the file extension used for shared libraries. Handles the
1410 *      following syntax:
1411 *
1412 *          info sharedlibextension
1413 *
1414 * Results:
1415 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
1416 *
1417 * Side effects:
1418 *      Returns a result in the interpreter's result object. If there is
1419 *      an error, the result is an error message.
1420 *
1421 *----------------------------------------------------------------------
1422 */
1423
1424static int
1425InfoSharedlibCmd(dummy, interp, objc, objv)
1426    ClientData dummy;           /* Not used. */
1427    Tcl_Interp *interp;         /* Current interpreter. */
1428    int objc;                   /* Number of arguments. */
1429    Tcl_Obj *CONST objv[];      /* Argument objects. */
1430{
1431    if (objc != 2) {
1432        Tcl_WrongNumArgs(interp, 2, objv, NULL);
1433        return TCL_ERROR;
1434    }
1435   
1436#ifdef TCL_SHLIB_EXT
1437    Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
1438#endif
1439    return TCL_OK;
1440}
1441
1442/*
1443 *----------------------------------------------------------------------
1444 *
1445 * InfoTclVersionCmd --
1446 *
1447 *      Called to implement the "info tclversion" command that returns the
1448 *      version number for this Tcl library. Handles the following syntax:
1449 *
1450 *          info tclversion
1451 *
1452 * Results:
1453 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
1454 *
1455 * Side effects:
1456 *      Returns a result in the interpreter's result object. If there is
1457 *      an error, the result is an error message.
1458 *
1459 *----------------------------------------------------------------------
1460 */
1461
1462static int
1463InfoTclVersionCmd(dummy, interp, objc, objv)
1464    ClientData dummy;           /* Not used. */
1465    Tcl_Interp *interp;         /* Current interpreter. */
1466    int objc;                   /* Number of arguments. */
1467    Tcl_Obj *CONST objv[];      /* Argument objects. */
1468{
1469    char *version;
1470
1471    if (objc != 2) {
1472        Tcl_WrongNumArgs(interp, 2, objv, NULL);
1473        return TCL_ERROR;
1474    }
1475
1476    version = Tcl_GetVar(interp, "tcl_version",
1477        (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
1478    if (version != NULL) {
1479        Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
1480        return TCL_OK;
1481    }
1482    return TCL_ERROR;
1483}
1484
1485/*
1486 *----------------------------------------------------------------------
1487 *
1488 * InfoVarsCmd --
1489 *
1490 *      Called to implement the "info vars" command that returns the
1491 *      list of variables in the interpreter that match an optional pattern.
1492 *      The pattern, if any, consists of an optional sequence of namespace
1493 *      names separated by "::" qualifiers, which is followed by a
1494 *      glob-style pattern that restricts which variables are returned.
1495 *      Handles the following syntax:
1496 *
1497 *          info vars ?pattern?
1498 *
1499 * Results:
1500 *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
1501 *
1502 * Side effects:
1503 *      Returns a result in the interpreter's result object. If there is
1504 *      an error, the result is an error message.
1505 *
1506 *----------------------------------------------------------------------
1507 */
1508
1509static int
1510InfoVarsCmd(dummy, interp, objc, objv)
1511    ClientData dummy;           /* Not used. */
1512    Tcl_Interp *interp;         /* Current interpreter. */
1513    int objc;                   /* Number of arguments. */
1514    Tcl_Obj *CONST objv[];      /* Argument objects. */
1515{
1516    Interp *iPtr = (Interp *) interp;
1517    char *varName, *pattern, *simplePattern;
1518    register Tcl_HashEntry *entryPtr;
1519    Tcl_HashSearch search;
1520    Var *varPtr;
1521    Namespace *nsPtr;
1522    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
1523    Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);
1524    Tcl_Obj *listPtr, *elemObjPtr;
1525    int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */
1526
1527    /*
1528     * Get the pattern and find the "effective namespace" in which to
1529     * list variables. We only use this effective namespace if there's
1530     * no active Tcl procedure frame.
1531     */
1532
1533    if (objc == 2) {
1534        simplePattern = NULL;
1535        nsPtr = currNsPtr;
1536        specificNsInPattern = 0;
1537    } else if (objc == 3) {
1538        /*
1539         * From the pattern, get the effective namespace and the simple
1540         * pattern (no namespace qualifiers or ::'s) at the end. If an
1541         * error was found while parsing the pattern, return it. Otherwise,
1542         * if the namespace wasn't found, just leave nsPtr NULL: we will
1543         * return an empty list since no variables there can be found.
1544         */
1545
1546        Namespace *dummy1NsPtr, *dummy2NsPtr;
1547
1548        pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
1549       TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
1550           /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
1551
1552        if (nsPtr != NULL) {    /* we successfully found the pattern's ns */
1553            specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
1554        }
1555    } else {
1556        Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1557        return TCL_ERROR;
1558    }
1559
1560    /*
1561     * If the namespace specified in the pattern wasn't found, just return.
1562     */
1563
1564    if (nsPtr == NULL) {
1565        return TCL_OK;
1566    }
1567   
1568    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1569   
1570    if ((iPtr->varFramePtr == NULL)
1571            || !iPtr->varFramePtr->isProcCallFrame
1572            || specificNsInPattern) {
1573        /*
1574         * There is no frame pointer, the frame pointer was pushed only
1575         * to activate a namespace, or we are in a procedure call frame
1576         * but a specific namespace was specified. Create a list containing
1577         * only the variables in the effective namespace's variable table.
1578         */
1579       
1580        entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
1581        while (entryPtr != NULL) {
1582            varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1583            if (!TclIsVarUndefined(varPtr)
1584                    || (varPtr->flags & VAR_NAMESPACE_VAR)) {
1585                varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
1586                if ((simplePattern == NULL)
1587                        || Tcl_StringMatch(varName, simplePattern)) {
1588                    if (specificNsInPattern) {
1589                        elemObjPtr = Tcl_NewObj();
1590                        Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
1591                                elemObjPtr);
1592                    } else {
1593                        elemObjPtr = Tcl_NewStringObj(varName, -1);
1594                    }
1595                    Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
1596                }
1597            }
1598            entryPtr = Tcl_NextHashEntry(&search);
1599        }
1600
1601        /*
1602         * If the effective namespace isn't the global :: namespace, and a
1603         * specific namespace wasn't requested in the pattern (i.e., the
1604         * pattern only specifies variable names), then add in all global ::
1605         * variables that match the simple pattern. Of course, add in only
1606         * those variables that aren't hidden by a variable in the effective
1607         * namespace.
1608         */
1609
1610        if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
1611            entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
1612            while (entryPtr != NULL) {
1613                varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1614                if (!TclIsVarUndefined(varPtr)
1615                        || (varPtr->flags & VAR_NAMESPACE_VAR)) {
1616                    varName = Tcl_GetHashKey(&globalNsPtr->varTable,
1617                            entryPtr);
1618                    if ((simplePattern == NULL)
1619                            || Tcl_StringMatch(varName, simplePattern)) {
1620                        if (Tcl_FindHashEntry(&nsPtr->varTable, varName) == NULL) {
1621                            Tcl_ListObjAppendElement(interp, listPtr,
1622                                    Tcl_NewStringObj(varName, -1));
1623                        }
1624                    }
1625                }
1626                entryPtr = Tcl_NextHashEntry(&search);
1627            }
1628        }
1629    } else {
1630        AppendLocals(interp, listPtr, simplePattern, 1);
1631    }
1632   
1633    Tcl_SetObjResult(interp, listPtr);
1634    return TCL_OK;
1635}
1636
1637/*
1638 *----------------------------------------------------------------------
1639 *
1640 * Tcl_JoinObjCmd --
1641 *
1642 *      This procedure is invoked to process the "join" Tcl command.
1643 *      See the user documentation for details on what it does.
1644 *
1645 * Results:
1646 *      A standard Tcl object result.
1647 *
1648 * Side effects:
1649 *      See the user documentation.
1650 *
1651 *----------------------------------------------------------------------
1652 */
1653
1654        /* ARGSUSED */
1655int
1656Tcl_JoinObjCmd(dummy, interp, objc, objv)
1657    ClientData dummy;           /* Not used. */
1658    Tcl_Interp *interp;         /* Current interpreter. */
1659    int objc;                   /* Number of arguments. */
1660    Tcl_Obj *CONST objv[];      /* The argument objects. */
1661{
1662    char *joinString, *bytes;
1663    int joinLength, listLen, length, i, result;
1664    Tcl_Obj **elemPtrs;
1665    Tcl_Obj *resObjPtr;
1666
1667    if (objc == 2) {
1668        joinString = " ";
1669        joinLength = 1;
1670    } else if (objc == 3) {
1671        joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
1672    } else {
1673        Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
1674        return TCL_ERROR;
1675    }
1676
1677    /*
1678     * Make sure the list argument is a list object and get its length and
1679     * a pointer to its array of element pointers.
1680     */
1681
1682    result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
1683    if (result != TCL_OK) {
1684        return result;
1685    }
1686
1687    /*
1688     * Now concatenate strings to form the "joined" result. We append
1689     * directly into the interpreter's result object.
1690     */
1691
1692    resObjPtr = Tcl_GetObjResult(interp);
1693
1694    for (i = 0;  i < listLen;  i++) {
1695        bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
1696        if (i > 0) {
1697            Tcl_AppendToObj(resObjPtr, joinString, joinLength);
1698        }
1699        Tcl_AppendToObj(resObjPtr, bytes, length);
1700    }
1701    return TCL_OK;
1702}
1703
1704/*
1705 *----------------------------------------------------------------------
1706 *
1707 * Tcl_LindexObjCmd --
1708 *
1709 *      This object-based procedure is invoked to process the "lindex" Tcl
1710 *      command. See the user documentation for details on what it does.
1711 *
1712 * Results:
1713 *      A standard Tcl object result.
1714 *
1715 * Side effects:
1716 *      See the user documentation.
1717 *
1718 *----------------------------------------------------------------------
1719 */
1720
1721    /* ARGSUSED */
1722int
1723Tcl_LindexObjCmd(dummy, interp, objc, objv)
1724    ClientData dummy;           /* Not used. */
1725    Tcl_Interp *interp;         /* Current interpreter. */
1726    int objc;                   /* Number of arguments. */
1727    Tcl_Obj *CONST objv[];      /* Argument objects. */
1728{
1729    Tcl_Obj *listPtr;
1730    Tcl_Obj **elemPtrs;
1731    int listLen, index, result;
1732
1733    if (objc != 3) {
1734        Tcl_WrongNumArgs(interp, 1, objv, "list index");
1735        return TCL_ERROR;
1736    }
1737
1738    /*
1739     * Convert the first argument to a list if necessary.
1740     */
1741
1742    listPtr = objv[1];
1743    result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
1744    if (result != TCL_OK) {
1745        return result;
1746    }
1747
1748    /*
1749     * Get the index from objv[2].
1750     */
1751
1752    result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
1753            &index);
1754    if (result != TCL_OK) {
1755        return result;
1756    }
1757    if ((index < 0) || (index >= listLen)) {
1758        /*
1759         * The index is out of range: the result is an empty string object.
1760         */
1761       
1762        return TCL_OK;
1763    }
1764
1765    /*
1766     * Make sure listPtr still refers to a list object. It might have been
1767     * converted to an int above if the argument objects were shared.
1768     */
1769
1770    if (listPtr->typePtr != &tclListType) {
1771        result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
1772                &elemPtrs);
1773        if (result != TCL_OK) {
1774            return result;
1775        }
1776    }
1777
1778    /*
1779     * Set the interpreter's object result to the index-th list element.
1780     */
1781
1782    Tcl_SetObjResult(interp, elemPtrs[index]);
1783    return TCL_OK;
1784}
1785
1786/*
1787 *----------------------------------------------------------------------
1788 *
1789 * Tcl_LinsertObjCmd --
1790 *
1791 *      This object-based procedure is invoked to process the "linsert" Tcl
1792 *      command. See the user documentation for details on what it does.
1793 *
1794 * Results:
1795 *      A new Tcl list object formed by inserting zero or more elements
1796 *      into a list.
1797 *
1798 * Side effects:
1799 *      See the user documentation.
1800 *
1801 *----------------------------------------------------------------------
1802 */
1803
1804        /* ARGSUSED */
1805int
1806Tcl_LinsertObjCmd(dummy, interp, objc, objv)
1807    ClientData dummy;           /* Not used. */
1808    Tcl_Interp *interp;         /* Current interpreter. */
1809    register int objc;          /* Number of arguments. */
1810    Tcl_Obj *CONST objv[];      /* Argument objects. */
1811{
1812    Tcl_Obj *listPtr, *resultPtr;
1813    Tcl_ObjType *typePtr;
1814    int index, isDuplicate, len, result;
1815
1816    if (objc < 4) {
1817        Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
1818        return TCL_ERROR;
1819    }
1820
1821    /*
1822     * Get the index first since, if a conversion to int is needed, it
1823     * will invalidate the list's internal representation.
1824     */
1825
1826    result = TclGetIntForIndex(interp, objv[2], /*endValue*/ INT_MAX,
1827            &index);
1828    if (result != TCL_OK) {
1829        return result;
1830    }
1831
1832    /*
1833     * If the list object is unshared we can modify it directly. Otherwise
1834     * we create a copy to modify: this is "copy on write". We create the
1835     * duplicate directly in the interpreter's object result.
1836     */
1837   
1838    listPtr = objv[1];
1839    isDuplicate = 0;
1840    if (Tcl_IsShared(listPtr)) {
1841        /*
1842         * The following code must reflect the logic in Tcl_DuplicateObj()
1843         * except that it must duplicate the list object directly into the
1844         * interpreter's result.
1845         */
1846       
1847        Tcl_ResetResult(interp);
1848        resultPtr = Tcl_GetObjResult(interp);
1849        typePtr = listPtr->typePtr;
1850        if (listPtr->bytes == NULL) {
1851            resultPtr->bytes = NULL;
1852        } else if (listPtr->bytes != tclEmptyStringRep) {
1853            len = listPtr->length;
1854            TclInitStringRep(resultPtr, listPtr->bytes, len);
1855        }
1856        if (typePtr != NULL) {
1857            if (typePtr->dupIntRepProc == NULL) {
1858                resultPtr->internalRep = listPtr->internalRep;
1859                resultPtr->typePtr = typePtr;
1860            } else {
1861                (*typePtr->dupIntRepProc)(listPtr, resultPtr);
1862            }
1863        }
1864        listPtr = resultPtr;
1865        isDuplicate = 1;
1866    }
1867   
1868    if ((objc == 4) && (index == INT_MAX)) {
1869        /*
1870         * Special case: insert one element at the end of the list.
1871         */
1872
1873        result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
1874    } else if (objc > 3) {
1875        result = Tcl_ListObjReplace(interp, listPtr, index, 0,
1876                                    (objc-3), &(objv[3]));
1877    }
1878    if (result != TCL_OK) {
1879        return result;
1880    }
1881   
1882    /*
1883     * Set the interpreter's object result.
1884     */
1885
1886    if (!isDuplicate) {
1887        Tcl_SetObjResult(interp, listPtr);
1888    }
1889    return TCL_OK;
1890}
1891
1892/*
1893 *----------------------------------------------------------------------
1894 *
1895 * Tcl_ListObjCmd --
1896 *
1897 *      This procedure is invoked to process the "list" Tcl command.
1898 *      See the user documentation for details on what it does.
1899 *
1900 * Results:
1901 *      A standard Tcl object result.
1902 *
1903 * Side effects:
1904 *      See the user documentation.
1905 *
1906 *----------------------------------------------------------------------
1907 */
1908
1909        /* ARGSUSED */
1910int
1911Tcl_ListObjCmd(dummy, interp, objc, objv)
1912    ClientData dummy;                   /* Not used. */
1913    Tcl_Interp *interp;                 /* Current interpreter. */
1914    register int objc;                  /* Number of arguments. */
1915    register Tcl_Obj *CONST objv[];     /* The argument objects. */
1916{
1917    /*
1918     * If there are no list elements, the result is an empty object.
1919     * Otherwise modify the interpreter's result object to be a list object.
1920     */
1921   
1922    if (objc > 1) {
1923        Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));
1924    }
1925    return TCL_OK;
1926}
1927
1928/*
1929 *----------------------------------------------------------------------
1930 *
1931 * Tcl_LlengthObjCmd --
1932 *
1933 *      This object-based procedure is invoked to process the "llength" Tcl
1934 *      command.  See the user documentation for details on what it does.
1935 *
1936 * Results:
1937 *      A standard Tcl object result.
1938 *
1939 * Side effects:
1940 *      See the user documentation.
1941 *
1942 *----------------------------------------------------------------------
1943 */
1944
1945        /* ARGSUSED */
1946int
1947Tcl_LlengthObjCmd(dummy, interp, objc, objv)
1948    ClientData dummy;                   /* Not used. */
1949    Tcl_Interp *interp;                 /* Current interpreter. */
1950    int objc;                           /* Number of arguments. */
1951    register Tcl_Obj *CONST objv[];     /* Argument objects. */
1952{
1953    int listLen, result;
1954
1955    if (objc != 2) {
1956        Tcl_WrongNumArgs(interp, 1, objv, "list");
1957        return TCL_ERROR;
1958    }
1959
1960    result = Tcl_ListObjLength(interp, objv[1], &listLen);
1961    if (result != TCL_OK) {
1962        return result;
1963    }
1964
1965    /*
1966     * Set the interpreter's object result to an integer object holding the
1967     * length.
1968     */
1969
1970    Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
1971    return TCL_OK;
1972}
1973
1974/*
1975 *----------------------------------------------------------------------
1976 *
1977 * Tcl_LrangeObjCmd --
1978 *
1979 *      This procedure is invoked to process the "lrange" Tcl command.
1980 *      See the user documentation for details on what it does.
1981 *
1982 * Results:
1983 *      A standard Tcl object result.
1984 *
1985 * Side effects:
1986 *      See the user documentation.
1987 *
1988 *----------------------------------------------------------------------
1989 */
1990
1991        /* ARGSUSED */
1992int
1993Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
1994    ClientData notUsed;                 /* Not used. */
1995    Tcl_Interp *interp;                 /* Current interpreter. */
1996    int objc;                           /* Number of arguments. */
1997    register Tcl_Obj *CONST objv[];     /* Argument objects. */
1998{
1999    Tcl_Obj *listPtr;
2000    Tcl_Obj **elemPtrs;
2001    int listLen, first, last, numElems, result;
2002
2003    if (objc != 4) {
2004        Tcl_WrongNumArgs(interp, 1, objv, "list first last");
2005        return TCL_ERROR;
2006    }
2007
2008    /*
2009     * Make sure the list argument is a list object and get its length and
2010     * a pointer to its array of element pointers.
2011     */
2012
2013    listPtr = objv[1];
2014    result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
2015    if (result != TCL_OK) {
2016        return result;
2017    }
2018
2019    /*
2020     * Get the first and last indexes.
2021     */
2022
2023    result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
2024            &first);
2025    if (result != TCL_OK) {
2026        return result;
2027    }
2028    if (first < 0) {
2029        first = 0;
2030    }
2031
2032    result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
2033            &last);
2034    if (result != TCL_OK) {
2035        return result;
2036    }
2037    if (last >= listLen) {
2038        last = (listLen - 1);
2039    }
2040   
2041    if (first > last) {
2042        return TCL_OK;          /* the result is an empty object */
2043    }
2044
2045    /*
2046     * Make sure listPtr still refers to a list object. It might have been
2047     * converted to an int above if the argument objects were shared.
2048     */ 
2049
2050    if (listPtr->typePtr != &tclListType) {
2051        result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
2052                &elemPtrs);
2053        if (result != TCL_OK) {
2054            return result;
2055        }
2056    }
2057
2058    /*
2059     * Extract a range of fields. We modify the interpreter's result object
2060     * to be a list object containing the specified elements.
2061     */
2062
2063    numElems = (last - first + 1);
2064    Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
2065    return TCL_OK;
2066}
2067
2068/*
2069 *----------------------------------------------------------------------
2070 *
2071 * Tcl_LreplaceObjCmd --
2072 *
2073 *      This object-based procedure is invoked to process the "lreplace"
2074 *      Tcl command. See the user documentation for details on what it does.
2075 *
2076 * Results:
2077 *      A new Tcl list object formed by replacing zero or more elements of
2078 *      a list.
2079 *
2080 * Side effects:
2081 *      See the user documentation.
2082 *
2083 *----------------------------------------------------------------------
2084 */
2085
2086        /* ARGSUSED */
2087int
2088Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
2089    ClientData dummy;           /* Not used. */
2090    Tcl_Interp *interp;         /* Current interpreter. */
2091    int objc;                   /* Number of arguments. */
2092    Tcl_Obj *CONST objv[];      /* Argument objects. */
2093{
2094    register Tcl_Obj *listPtr;
2095    int createdNewObj, first, last, listLen, numToDelete;
2096    int firstArgLen, result;
2097    char *firstArg;
2098
2099    if (objc < 4) {
2100        Tcl_WrongNumArgs(interp, 1, objv,
2101                "list first last ?element element ...?");
2102        return TCL_ERROR;
2103    }
2104
2105    /*
2106     * If the list object is unshared we can modify it directly, otherwise
2107     * we create a copy to modify: this is "copy on write".
2108     */
2109   
2110    listPtr = objv[1];
2111    createdNewObj = 0;
2112    if (Tcl_IsShared(listPtr)) {
2113        listPtr = Tcl_DuplicateObj(listPtr);
2114        createdNewObj = 1;
2115    }
2116    result = Tcl_ListObjLength(interp, listPtr, &listLen);
2117    if (result != TCL_OK) {
2118        errorReturn:
2119        if (createdNewObj) {
2120            Tcl_DecrRefCount(listPtr); /* free unneeded obj */
2121        }
2122        return result;
2123    }
2124
2125    /*
2126     * Get the first and last indexes.
2127     */
2128
2129    result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
2130            &first);
2131    if (result != TCL_OK) {
2132        goto errorReturn;
2133    }
2134    firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen);
2135
2136    result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
2137            &last);
2138    if (result != TCL_OK) {
2139        goto errorReturn;
2140    }
2141
2142    if (first < 0)  {
2143        first = 0;
2144    }
2145    if ((first >= listLen) && (listLen > 0)
2146            && (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) {
2147        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2148                "list doesn't contain element ",
2149                Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL);
2150        result = TCL_ERROR;
2151        goto errorReturn;
2152    }
2153    if (last >= listLen) {
2154        last = (listLen - 1);
2155    }
2156    if (first <= last) {
2157        numToDelete = (last - first + 1);
2158    } else {
2159        numToDelete = 0;
2160    }
2161
2162    if (objc > 4) {
2163        result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
2164                (objc-4), &(objv[4]));
2165    } else {
2166        result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
2167                0, NULL);
2168    }
2169    if (result != TCL_OK) {
2170        goto errorReturn;
2171    }
2172
2173    /*
2174     * Set the interpreter's object result.
2175     */
2176
2177    Tcl_SetObjResult(interp, listPtr);
2178    return TCL_OK;
2179}
2180
2181/*
2182 *----------------------------------------------------------------------
2183 *
2184 * Tcl_LsortObjCmd --
2185 *
2186 *      This procedure is invoked to process the "lsort" Tcl command.
2187 *      See the user documentation for details on what it does.
2188 *
2189 * Results:
2190 *      A standard Tcl result.
2191 *
2192 * Side effects:
2193 *      See the user documentation.
2194 *
2195 *----------------------------------------------------------------------
2196 */
2197
2198int
2199Tcl_LsortObjCmd(clientData, interp, objc, objv)
2200    ClientData clientData;      /* Not used. */
2201    Tcl_Interp *interp;         /* Current interpreter. */
2202    int objc;                   /* Number of arguments. */
2203    Tcl_Obj *CONST objv[];      /* Argument values. */
2204{
2205    int i, index, dummy;
2206    Tcl_Obj *resultPtr;
2207    int length;
2208    Tcl_Obj *cmdPtr, **listObjPtrs;
2209    SortElement *elementArray;
2210    SortElement *elementPtr;       
2211    SortInfo sortInfo;                  /* Information about this sort that
2212                                         * needs to be passed to the
2213                                         * comparison function */
2214    static char *switches[] =
2215            {"-ascii", "-command", "-decreasing", "-dictionary",
2216            "-increasing", "-index", "-integer", "-real", (char *) NULL};
2217
2218    resultPtr = Tcl_GetObjResult(interp);
2219    if (objc < 2) {
2220        Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
2221        return TCL_ERROR;
2222    }
2223
2224    /*
2225     * Parse arguments to set up the mode for the sort.
2226     */
2227
2228    sortInfo.isIncreasing = 1;
2229    sortInfo.sortMode = SORTMODE_ASCII;
2230    sortInfo.index = -1;
2231    sortInfo.interp = interp;
2232    sortInfo.resultCode = TCL_OK;
2233    cmdPtr = NULL;
2234    for (i = 1; i < objc-1; i++) {
2235        if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
2236                != TCL_OK) {
2237            return TCL_ERROR;
2238        }
2239        switch (index) {
2240            case 0:                     /* -ascii */
2241                sortInfo.sortMode = SORTMODE_ASCII;
2242                break;
2243            case 1:                     /* -command */
2244                if (i == (objc-2)) {
2245                    Tcl_AppendToObj(resultPtr,
2246                            "\"-command\" option must be followed by comparison command",
2247                            -1);
2248                    return TCL_ERROR;
2249                }
2250                sortInfo.sortMode = SORTMODE_COMMAND;
2251                cmdPtr = objv[i+1];
2252                i++;
2253                break;
2254            case 2:                     /* -decreasing */
2255                sortInfo.isIncreasing = 0;
2256                break;
2257            case 3:                     /* -dictionary */
2258                sortInfo.sortMode = SORTMODE_DICTIONARY;
2259                break;
2260            case 4:                     /* -increasing */
2261                sortInfo.isIncreasing = 1;
2262                break;
2263            case 5:                     /* -index */
2264                if (i == (objc-2)) {
2265                    Tcl_AppendToObj(resultPtr,
2266                            "\"-index\" option must be followed by list index",
2267                            -1);
2268                    return TCL_ERROR;
2269                }
2270                if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index)
2271                        != TCL_OK) {
2272                    return TCL_ERROR;
2273                }
2274                cmdPtr = objv[i+1];
2275                i++;
2276                break;
2277            case 6:                     /* -integer */
2278                sortInfo.sortMode = SORTMODE_INTEGER;
2279                break;
2280            case 7:                     /* -real */
2281                sortInfo.sortMode = SORTMODE_REAL;
2282                break;
2283        }
2284    }
2285    if (sortInfo.sortMode == SORTMODE_COMMAND) {
2286        Tcl_DStringInit(&sortInfo.compareCmd);
2287        Tcl_DStringAppend(&sortInfo.compareCmd,
2288                Tcl_GetStringFromObj(cmdPtr, &dummy), -1);
2289    }
2290
2291    sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
2292            &length, &listObjPtrs);
2293    if (sortInfo.resultCode != TCL_OK) {
2294        goto done;
2295    }
2296    if (length <= 0) {
2297        return TCL_OK;
2298    }
2299    elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
2300    for (i=0; i < length; i++){
2301        elementArray[i].objPtr = listObjPtrs[i];
2302        elementArray[i].nextPtr = &elementArray[i+1];
2303    }
2304    elementArray[length-1].nextPtr = NULL;
2305    elementPtr = MergeSort(elementArray, &sortInfo);
2306    if (sortInfo.resultCode == TCL_OK) {
2307        /*
2308         * Note: must clear the interpreter's result object: it could
2309         * have been set by the -command script.
2310         */
2311
2312        Tcl_ResetResult(interp);
2313        resultPtr = Tcl_GetObjResult(interp);
2314        for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
2315            Tcl_ListObjAppendElement(interp, resultPtr, elementPtr->objPtr);
2316        }
2317    }
2318    ckfree((char*) elementArray);
2319
2320    done:
2321    if (sortInfo.sortMode == SORTMODE_COMMAND) {
2322        Tcl_DStringFree(&sortInfo.compareCmd);
2323    }
2324    return sortInfo.resultCode;
2325}
2326
2327/*
2328 *----------------------------------------------------------------------
2329 *
2330 * MergeSort -
2331 *
2332 *      This procedure sorts a linked list of SortElement structures
2333 *      use the merge-sort algorithm.
2334 *
2335 * Results:
2336 *      A pointer to the head of the list after sorting is returned.
2337 *
2338 * Side effects:
2339 *      None, unless a user-defined comparison command does something
2340 *      weird.
2341 *
2342 *----------------------------------------------------------------------
2343 */
2344
2345static SortElement *
2346MergeSort(headPtr, infoPtr)
2347    SortElement *headPtr;               /* First element on the list */
2348    SortInfo *infoPtr;                  /* Information needed by the
2349                                         * comparison operator */
2350{
2351    /*
2352     * The subList array below holds pointers to temporary lists built
2353     * during the merge sort.  Element i of the array holds a list of
2354     * length 2**i.
2355     */
2356
2357#   define NUM_LISTS 30
2358    SortElement *subList[NUM_LISTS];
2359    SortElement *elementPtr;
2360    int i;
2361
2362    for(i = 0; i < NUM_LISTS; i++){
2363        subList[i] = NULL;
2364    }
2365    while (headPtr != NULL) {
2366        elementPtr = headPtr;
2367        headPtr = headPtr->nextPtr;
2368        elementPtr->nextPtr = 0;
2369        for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
2370            elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
2371            subList[i] = NULL;
2372        }
2373        if (i >= NUM_LISTS) {
2374            i = NUM_LISTS-1;
2375        }
2376        subList[i] = elementPtr;
2377    }
2378    elementPtr = NULL;
2379    for (i = 0; i < NUM_LISTS; i++){
2380        elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
2381    }
2382    return elementPtr;
2383}
2384
2385/*
2386 *----------------------------------------------------------------------
2387 *
2388 * MergeLists -
2389 *
2390 *      This procedure combines two sorted lists of SortElement structures
2391 *      into a single sorted list.
2392 *
2393 * Results:
2394 *      The unified list of SortElement structures.
2395 *
2396 * Side effects:
2397 *      None, unless a user-defined comparison command does something
2398 *      weird.
2399 *
2400 *----------------------------------------------------------------------
2401 */
2402
2403static SortElement *
2404MergeLists(leftPtr, rightPtr, infoPtr)
2405    SortElement *leftPtr;               /* First list to be merged; may be
2406                                         * NULL. */
2407    SortElement *rightPtr;              /* Second list to be merged; may be
2408                                         * NULL. */
2409    SortInfo *infoPtr;                  /* Information needed by the
2410                                         * comparison operator. */
2411{
2412    SortElement *headPtr;
2413    SortElement *tailPtr;
2414
2415    if (leftPtr == NULL) {
2416        return rightPtr;
2417    }
2418    if (rightPtr == NULL) {
2419        return leftPtr;
2420    }
2421    if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
2422        tailPtr = rightPtr;
2423        rightPtr = rightPtr->nextPtr;
2424    } else {
2425        tailPtr = leftPtr;
2426        leftPtr = leftPtr->nextPtr;
2427    }
2428    headPtr = tailPtr;
2429    while ((leftPtr != NULL) && (rightPtr != NULL)) {
2430        if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
2431            tailPtr->nextPtr = rightPtr;
2432            tailPtr = rightPtr;
2433            rightPtr = rightPtr->nextPtr;
2434        } else {
2435            tailPtr->nextPtr = leftPtr;
2436            tailPtr = leftPtr;
2437            leftPtr = leftPtr->nextPtr;
2438        }
2439    }
2440    if (leftPtr != NULL) {
2441       tailPtr->nextPtr = leftPtr;
2442    } else {
2443       tailPtr->nextPtr = rightPtr;
2444    }
2445    return headPtr;
2446}
2447
2448/*
2449 *----------------------------------------------------------------------
2450 *
2451 * SortCompare --
2452 *
2453 *      This procedure is invoked by MergeLists to determine the proper
2454 *      ordering between two elements.
2455 *
2456 * Results:
2457 *      A negative results means the the first element comes before the
2458 *      second, and a positive results means that the second element
2459 *      should come first.  A result of zero means the two elements
2460 *      are equal and it doesn't matter which comes first.
2461 *
2462 * Side effects:
2463 *      None, unless a user-defined comparison command does something
2464 *      weird.
2465 *
2466 *----------------------------------------------------------------------
2467 */
2468
2469static int
2470SortCompare(objPtr1, objPtr2, infoPtr)
2471    Tcl_Obj *objPtr1, *objPtr2;         /* Values to be compared. */
2472    SortInfo *infoPtr;                  /* Information passed from the
2473                                         * top-level "lsort" command */
2474{
2475    int order, dummy, listLen, index;
2476    Tcl_Obj *objPtr;
2477    char buffer[30];
2478
2479    order = 0;
2480    if (infoPtr->resultCode != TCL_OK) {
2481        /*
2482         * Once an error has occurred, skip any future comparisons
2483         * so as to preserve the error message in sortInterp->result.
2484         */
2485
2486        return order;
2487    }
2488    if (infoPtr->index != -1) {
2489        /*
2490         * The "-index" option was specified.  Treat each object as a
2491         * list, extract the requested element from each list, and
2492         * compare the elements, not the lists.  The special index "end"
2493         * is signaled here with a large negative index.
2494         */
2495
2496        if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
2497            infoPtr->resultCode = TCL_ERROR;
2498            return order;
2499        }
2500        if (infoPtr->index < -1) {
2501            index = listLen - 1;
2502        } else {
2503            index = infoPtr->index;
2504        }
2505
2506        if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)
2507                != TCL_OK) {
2508            infoPtr->resultCode = TCL_ERROR;
2509            return order;
2510        }
2511        if (objPtr == NULL) {
2512            objPtr = objPtr1;
2513            missingElement:
2514            sprintf(buffer, "%d", infoPtr->index);
2515            Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
2516                        "element ", buffer, " missing from sublist \"",
2517                        Tcl_GetStringFromObj(objPtr, (int *) NULL),
2518                        "\"", (char *) NULL);
2519            infoPtr->resultCode = TCL_ERROR;
2520            return order;
2521        }
2522        objPtr1 = objPtr;
2523
2524        if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {
2525            infoPtr->resultCode = TCL_ERROR;
2526            return order;
2527        }
2528        if (infoPtr->index < -1) {
2529            index = listLen - 1;
2530        } else {
2531            index = infoPtr->index;
2532        }
2533
2534        if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)
2535                != TCL_OK) {
2536            infoPtr->resultCode = TCL_ERROR;
2537            return order;
2538        }
2539        if (objPtr == NULL) {
2540            objPtr = objPtr2;
2541            goto missingElement;
2542        }
2543        objPtr2 = objPtr;
2544    }
2545    if (infoPtr->sortMode == SORTMODE_ASCII) {
2546        order = strcmp(Tcl_GetStringFromObj(objPtr1, &dummy),
2547                Tcl_GetStringFromObj(objPtr2, &dummy));
2548    } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
2549        order = DictionaryCompare(
2550                Tcl_GetStringFromObj(objPtr1, &dummy),
2551                Tcl_GetStringFromObj(objPtr2, &dummy));
2552    } else if (infoPtr->sortMode == SORTMODE_INTEGER) {
2553        int a, b;
2554
2555        if ((Tcl_GetIntFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
2556                || (Tcl_GetIntFromObj(infoPtr->interp, objPtr2, &b)
2557                != TCL_OK)) {
2558            infoPtr->resultCode = TCL_ERROR;
2559            return order;
2560        }
2561        if (a > b) {
2562            order = 1;
2563        } else if (b > a) {
2564            order = -1;
2565        }
2566    } else if (infoPtr->sortMode == SORTMODE_REAL) {
2567        double a, b;
2568
2569        if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
2570              || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
2571                      != TCL_OK)) {
2572            infoPtr->resultCode = TCL_ERROR;
2573            return order;
2574        }
2575        if (a > b) {
2576            order = 1;
2577        } else if (b > a) {
2578            order = -1;
2579        }
2580    } else {
2581        int oldLength;
2582
2583        /*
2584         * Generate and evaluate a command to determine which string comes
2585         * first.
2586         */
2587
2588        oldLength = Tcl_DStringLength(&infoPtr->compareCmd);
2589        Tcl_DStringAppendElement(&infoPtr->compareCmd,
2590                Tcl_GetStringFromObj(objPtr1, &dummy));
2591        Tcl_DStringAppendElement(&infoPtr->compareCmd,
2592                Tcl_GetStringFromObj(objPtr2, &dummy));
2593        infoPtr->resultCode = Tcl_Eval(infoPtr->interp, 
2594                Tcl_DStringValue(&infoPtr->compareCmd));
2595        Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength);
2596        if (infoPtr->resultCode != TCL_OK) {
2597            Tcl_AddErrorInfo(infoPtr->interp,
2598                    "\n    (-compare command)");
2599            return order;
2600        }
2601
2602        /*
2603         * Parse the result of the command.
2604         */
2605
2606        if (Tcl_GetIntFromObj(infoPtr->interp,
2607                Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
2608            Tcl_ResetResult(infoPtr->interp);
2609            Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
2610                    "-compare command returned non-numeric result", -1);
2611            infoPtr->resultCode = TCL_ERROR;
2612            return order;
2613        }
2614    }
2615    if (!infoPtr->isIncreasing) {
2616        order = -order;
2617    }
2618    return order;
2619}
2620
2621/*
2622 *----------------------------------------------------------------------
2623 *
2624 * DictionaryCompare
2625 *
2626 *      This function compares two strings as if they were being used in
2627 *      an index or card catalog.  The case of alphabetic characters is
2628 *      ignored, except to break ties.  Thus "B" comes before "b" but
2629 *      after "a".  Also, integers embedded in the strings compare in
2630 *      numerical order.  In other words, "x10y" comes after "x9y", not
2631 *      before it as it would when using strcmp().
2632 *
2633 * Results:
2634 *      A negative result means that the first element comes before the
2635 *      second, and a positive result means that the second element
2636 *      should come first.  A result of zero means the two elements
2637 *      are equal and it doesn't matter which comes first.
2638 *
2639 * Side effects:
2640 *      None.
2641 *
2642 *----------------------------------------------------------------------
2643 */
2644
2645static int
2646DictionaryCompare(left, right)
2647    char *left, *right;          /* The strings to compare */
2648{
2649    int diff, zeros;
2650    int secondaryDiff = 0;
2651
2652    while (1) {
2653        if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) {
2654            /*
2655             * There are decimal numbers embedded in the two
2656             * strings.  Compare them as numbers, rather than
2657             * strings.  If one number has more leading zeros than
2658             * the other, the number with more leading zeros sorts
2659             * later, but only as a secondary choice.
2660             */
2661
2662            zeros = 0;
2663            while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
2664                right++;
2665                zeros--;
2666            }
2667            while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
2668                left++;
2669                zeros++;
2670            }
2671            if (secondaryDiff == 0) {
2672                secondaryDiff = zeros;
2673            }
2674
2675            /*
2676             * The code below compares the numbers in the two
2677             * strings without ever converting them to integers.  It
2678             * does this by first comparing the lengths of the
2679             * numbers and then comparing the digit values.
2680             */
2681
2682            diff = 0;
2683            while (1) {
2684                if (diff == 0) {
2685                    diff = UCHAR(*left) - UCHAR(*right);
2686                }
2687                right++;
2688                left++;
2689                if (!isdigit(UCHAR(*right))) {
2690                    if (isdigit(UCHAR(*left))) {
2691                        return 1;
2692                    } else {
2693                        /*
2694                         * The two numbers have the same length. See
2695                         * if their values are different.
2696                         */
2697
2698                        if (diff != 0) {
2699                            return diff;
2700                        }
2701                        break;
2702                    }
2703                } else if (!isdigit(UCHAR(*left))) {
2704                    return -1;
2705                }
2706            }
2707            continue;
2708        }
2709        diff = UCHAR(*left) - UCHAR(*right);
2710        if (diff) {
2711            if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) {
2712                diff = UCHAR(tolower(*left)) - UCHAR(*right);
2713                if (diff) {
2714                    return diff;
2715                } else if (secondaryDiff == 0) {
2716                    secondaryDiff = -1;
2717                }
2718            } else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) {
2719                diff = UCHAR(*left) - UCHAR(tolower(UCHAR(*right)));
2720                if (diff) {
2721                    return diff;
2722                } else if (secondaryDiff == 0) {
2723                    secondaryDiff = 1;
2724                }
2725            } else {
2726                return diff;
2727            }
2728        }
2729        if (*left == 0) {
2730            break;
2731        }
2732        left++;
2733        right++;
2734    }
2735    if (diff == 0) {
2736        diff = secondaryDiff;
2737    }
2738    return diff;
2739}
Note: See TracBrowser for help on using the repository browser.