/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdil.c
ViewVC logotype

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdil.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25