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

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25