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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.70  
changed lines
  Added in v.71

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25