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

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdah.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   * tclCmdAH.c --   * tclCmdAH.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   *      A to H.   *      A to H.
8   *   *
9   * Copyright (c) 1987-1993 The Regents of the University of California.   * Copyright (c) 1987-1993 The Regents of the University of California.
10   * Copyright (c) 1994-1997 Sun Microsystems, Inc.   * Copyright (c) 1994-1997 Sun Microsystems, Inc.
11   *   *
12   * See the file "license.terms" for information on usage and redistribution   * See the file "license.terms" for information on usage and redistribution
13   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14   *   *
15   * RCS: @(#) $Id: tclcmdah.c,v 1.1.1.1 2001/06/13 04:34:24 dtashley Exp $   * RCS: @(#) $Id: tclcmdah.c,v 1.1.1.1 2001/06/13 04:34:24 dtashley Exp $
16   */   */
17    
18  #include "tclInt.h"  #include "tclInt.h"
19  #include "tclPort.h"  #include "tclPort.h"
20  #include <locale.h>  #include <locale.h>
21    
22  typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf));  typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf));
23    
24  /*  /*
25   * Prototypes for local procedures defined in this file:   * Prototypes for local procedures defined in this file:
26   */   */
27    
28  static int              CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,  static int              CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,
29                              Tcl_Obj *objPtr, int mode));                              Tcl_Obj *objPtr, int mode));
30  static int              GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,  static int              GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,
31                              Tcl_Obj *objPtr, StatProc *statProc,                              Tcl_Obj *objPtr, StatProc *statProc,
32                              struct stat *statPtr));                              struct stat *statPtr));
33  static char *           GetTypeFromMode _ANSI_ARGS_((int mode));  static char *           GetTypeFromMode _ANSI_ARGS_((int mode));
34  static int              SplitPath _ANSI_ARGS_((Tcl_Interp *interp,  static int              SplitPath _ANSI_ARGS_((Tcl_Interp *interp,
35                              Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr));                              Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr));
36  static int              StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,  static int              StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
37                              char *varName, struct stat *statPtr));                              char *varName, struct stat *statPtr));
38  static char **          StringifyObjects _ANSI_ARGS_((int objc,  static char **          StringifyObjects _ANSI_ARGS_((int objc,
39                              Tcl_Obj *CONST objv[]));                              Tcl_Obj *CONST objv[]));
40    
41  /*  /*
42   *----------------------------------------------------------------------   *----------------------------------------------------------------------
43   *   *
44   * Tcl_BreakObjCmd --   * Tcl_BreakObjCmd --
45   *   *
46   *      This procedure is invoked to process the "break" Tcl command.   *      This procedure is invoked to process the "break" Tcl command.
47   *      See the user documentation for details on what it does.   *      See the user documentation for details on what it does.
48   *   *
49   *      With the bytecode compiler, this procedure is only called when   *      With the bytecode compiler, this procedure is only called when
50   *      a command name is computed at runtime, and is "break" or the name   *      a command name is computed at runtime, and is "break" or the name
51   *      to which "break" was renamed: e.g., "set z break; $z"   *      to which "break" was renamed: e.g., "set z break; $z"
52   *   *
53   * Results:   * Results:
54   *      A standard Tcl result.   *      A standard Tcl result.
55   *   *
56   * Side effects:   * Side effects:
57   *      See the user documentation.   *      See the user documentation.
58   *   *
59   *----------------------------------------------------------------------   *----------------------------------------------------------------------
60   */   */
61    
62          /* ARGSUSED */          /* ARGSUSED */
63  int  int
64  Tcl_BreakObjCmd(dummy, interp, objc, objv)  Tcl_BreakObjCmd(dummy, interp, objc, objv)
65      ClientData dummy;                   /* Not used. */      ClientData dummy;                   /* Not used. */
66      Tcl_Interp *interp;                 /* Current interpreter. */      Tcl_Interp *interp;                 /* Current interpreter. */
67      int objc;                           /* Number of arguments. */      int objc;                           /* Number of arguments. */
68      Tcl_Obj *CONST objv[];              /* Argument objects. */      Tcl_Obj *CONST objv[];              /* Argument objects. */
69  {  {
70      if (objc != 1) {      if (objc != 1) {
71          Tcl_WrongNumArgs(interp, 1, objv, NULL);          Tcl_WrongNumArgs(interp, 1, objv, NULL);
72          return TCL_ERROR;          return TCL_ERROR;
73      }      }
74      return TCL_BREAK;      return TCL_BREAK;
75  }  }
76    
77  /*  /*
78   *----------------------------------------------------------------------   *----------------------------------------------------------------------
79   *   *
80   * Tcl_CaseObjCmd --   * Tcl_CaseObjCmd --
81   *   *
82   *      This procedure is invoked to process the "case" Tcl command.   *      This procedure is invoked to process the "case" Tcl command.
83   *      See the user documentation for details on what it does.   *      See the user documentation for details on what it does.
84   *   *
85   * Results:   * Results:
86   *      A standard Tcl object result.   *      A standard Tcl object result.
87   *   *
88   * Side effects:   * Side effects:
89   *      See the user documentation.   *      See the user documentation.
90   *   *
91   *----------------------------------------------------------------------   *----------------------------------------------------------------------
92   */   */
93    
94          /* ARGSUSED */          /* ARGSUSED */
95  int  int
96  Tcl_CaseObjCmd(dummy, interp, objc, objv)  Tcl_CaseObjCmd(dummy, interp, objc, objv)
97      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
98      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
99      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
100      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
101  {  {
102      register int i;      register int i;
103      int body, result;      int body, result;
104      char *string, *arg;      char *string, *arg;
105      int caseObjc;      int caseObjc;
106      Tcl_Obj *CONST *caseObjv;      Tcl_Obj *CONST *caseObjv;
107      Tcl_Obj *armPtr;      Tcl_Obj *armPtr;
108    
109      if (objc < 3) {      if (objc < 3) {
110          Tcl_WrongNumArgs(interp, 1, objv,          Tcl_WrongNumArgs(interp, 1, objv,
111                  "string ?in? patList body ... ?default body?");                  "string ?in? patList body ... ?default body?");
112          return TCL_ERROR;          return TCL_ERROR;
113      }      }
114    
115      string = Tcl_GetString(objv[1]);      string = Tcl_GetString(objv[1]);
116      body = -1;      body = -1;
117    
118      arg = Tcl_GetString(objv[2]);      arg = Tcl_GetString(objv[2]);
119      if (strcmp(arg, "in") == 0) {      if (strcmp(arg, "in") == 0) {
120          i = 3;          i = 3;
121      } else {      } else {
122          i = 2;          i = 2;
123      }      }
124      caseObjc = objc - i;      caseObjc = objc - i;
125      caseObjv = objv + i;      caseObjv = objv + i;
126    
127      /*      /*
128       * If all of the pattern/command pairs are lumped into a single       * If all of the pattern/command pairs are lumped into a single
129       * argument, split them out again.       * argument, split them out again.
130       */       */
131    
132      if (caseObjc == 1) {      if (caseObjc == 1) {
133          Tcl_Obj **newObjv;          Tcl_Obj **newObjv;
134                    
135          Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);          Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
136          caseObjv = newObjv;          caseObjv = newObjv;
137      }      }
138    
139      for (i = 0;  i < caseObjc;  i += 2) {      for (i = 0;  i < caseObjc;  i += 2) {
140          int patObjc, j;          int patObjc, j;
141          char **patObjv;          char **patObjv;
142          char *pat;          char *pat;
143          unsigned char *p;          unsigned char *p;
144    
145          if (i == (caseObjc - 1)) {          if (i == (caseObjc - 1)) {
146              Tcl_ResetResult(interp);              Tcl_ResetResult(interp);
147              Tcl_AppendToObj(Tcl_GetObjResult(interp),              Tcl_AppendToObj(Tcl_GetObjResult(interp),
148                      "extra case pattern with no body", -1);                      "extra case pattern with no body", -1);
149              return TCL_ERROR;              return TCL_ERROR;
150          }          }
151    
152          /*          /*
153           * Check for special case of single pattern (no list) with           * Check for special case of single pattern (no list) with
154           * no backslash sequences.           * no backslash sequences.
155           */           */
156    
157          pat = Tcl_GetString(caseObjv[i]);          pat = Tcl_GetString(caseObjv[i]);
158          for (p = (unsigned char *) pat; *p != '\0'; p++) {          for (p = (unsigned char *) pat; *p != '\0'; p++) {
159              if (isspace(*p) || (*p == '\\')) {  /* INTL: ISO space, UCHAR */              if (isspace(*p) || (*p == '\\')) {  /* INTL: ISO space, UCHAR */
160                  break;                  break;
161              }              }
162          }          }
163          if (*p == '\0') {          if (*p == '\0') {
164              if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {              if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
165                  body = i + 1;                  body = i + 1;
166              }              }
167              if (Tcl_StringMatch(string, pat)) {              if (Tcl_StringMatch(string, pat)) {
168                  body = i + 1;                  body = i + 1;
169                  goto match;                  goto match;
170              }              }
171              continue;              continue;
172          }          }
173    
174    
175          /*          /*
176           * Break up pattern lists, then check each of the patterns           * Break up pattern lists, then check each of the patterns
177           * in the list.           * in the list.
178           */           */
179    
180          result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);          result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
181          if (result != TCL_OK) {          if (result != TCL_OK) {
182              return result;              return result;
183          }          }
184          for (j = 0; j < patObjc; j++) {          for (j = 0; j < patObjc; j++) {
185              if (Tcl_StringMatch(string, patObjv[j])) {              if (Tcl_StringMatch(string, patObjv[j])) {
186                  body = i + 1;                  body = i + 1;
187                  break;                  break;
188              }              }
189          }          }
190          ckfree((char *) patObjv);          ckfree((char *) patObjv);
191          if (j < patObjc) {          if (j < patObjc) {
192              break;              break;
193          }          }
194      }      }
195    
196      match:      match:
197      if (body != -1) {      if (body != -1) {
198          armPtr = caseObjv[body - 1];          armPtr = caseObjv[body - 1];
199          result = Tcl_EvalObjEx(interp, caseObjv[body], 0);          result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
200          if (result == TCL_ERROR) {          if (result == TCL_ERROR) {
201              char msg[100 + TCL_INTEGER_SPACE];              char msg[100 + TCL_INTEGER_SPACE];
202                            
203              arg = Tcl_GetString(armPtr);              arg = Tcl_GetString(armPtr);
204              sprintf(msg,              sprintf(msg,
205                      "\n    (\"%.50s\" arm line %d)", arg,                      "\n    (\"%.50s\" arm line %d)", arg,
206                      interp->errorLine);                      interp->errorLine);
207              Tcl_AddObjErrorInfo(interp, msg, -1);              Tcl_AddObjErrorInfo(interp, msg, -1);
208          }          }
209          return result;          return result;
210      }      }
211    
212      /*      /*
213       * Nothing matched: return nothing.       * Nothing matched: return nothing.
214       */       */
215    
216      return TCL_OK;      return TCL_OK;
217  }  }
218    
219  /*  /*
220   *----------------------------------------------------------------------   *----------------------------------------------------------------------
221   *   *
222   * Tcl_CatchObjCmd --   * Tcl_CatchObjCmd --
223   *   *
224   *      This object-based procedure is invoked to process the "catch" Tcl   *      This object-based procedure is invoked to process the "catch" Tcl
225   *      command. See the user documentation for details on what it does.   *      command. See the user documentation for details on what it does.
226   *   *
227   * Results:   * Results:
228   *      A standard Tcl object result.   *      A standard Tcl object result.
229   *   *
230   * Side effects:   * Side effects:
231   *      See the user documentation.   *      See the user documentation.
232   *   *
233   *----------------------------------------------------------------------   *----------------------------------------------------------------------
234   */   */
235    
236          /* ARGSUSED */          /* ARGSUSED */
237  int  int
238  Tcl_CatchObjCmd(dummy, interp, objc, objv)  Tcl_CatchObjCmd(dummy, interp, objc, objv)
239      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
240      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
241      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
242      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
243  {  {
244      Tcl_Obj *varNamePtr = NULL;      Tcl_Obj *varNamePtr = NULL;
245      int result;      int result;
246    
247      if ((objc != 2) && (objc != 3)) {      if ((objc != 2) && (objc != 3)) {
248          Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");          Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
249          return TCL_ERROR;          return TCL_ERROR;
250      }      }
251    
252      /*      /*
253       * Save a pointer to the variable name object, if any, in case the       * Save a pointer to the variable name object, if any, in case the
254       * Tcl_EvalObj reallocates the bytecode interpreter's evaluation       * Tcl_EvalObj reallocates the bytecode interpreter's evaluation
255       * stack rendering objv invalid.       * stack rendering objv invalid.
256       */       */
257            
258      if (objc == 3) {      if (objc == 3) {
259          varNamePtr = objv[2];          varNamePtr = objv[2];
260      }      }
261    
262      result = Tcl_EvalObjEx(interp, objv[1], 0);      result = Tcl_EvalObjEx(interp, objv[1], 0);
263            
264      if (objc == 3) {      if (objc == 3) {
265          if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,          if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
266                  Tcl_GetObjResult(interp), 0) == NULL) {                  Tcl_GetObjResult(interp), 0) == NULL) {
267              Tcl_ResetResult(interp);              Tcl_ResetResult(interp);
268              Tcl_AppendToObj(Tcl_GetObjResult(interp),                Tcl_AppendToObj(Tcl_GetObjResult(interp),  
269                      "couldn't save command result in variable", -1);                      "couldn't save command result in variable", -1);
270              return TCL_ERROR;              return TCL_ERROR;
271          }          }
272      }      }
273    
274      /*      /*
275       * Set the interpreter's object result to an integer object holding the       * Set the interpreter's object result to an integer object holding the
276       * integer Tcl_EvalObj result. Note that we don't bother generating a       * integer Tcl_EvalObj result. Note that we don't bother generating a
277       * string representation. We reset the interpreter's object result       * string representation. We reset the interpreter's object result
278       * to an unshared empty object and then set it to be an integer object.       * to an unshared empty object and then set it to be an integer object.
279       */       */
280    
281      Tcl_ResetResult(interp);      Tcl_ResetResult(interp);
282      Tcl_SetIntObj(Tcl_GetObjResult(interp), result);      Tcl_SetIntObj(Tcl_GetObjResult(interp), result);
283      return TCL_OK;      return TCL_OK;
284  }  }
285    
286  /*  /*
287   *----------------------------------------------------------------------   *----------------------------------------------------------------------
288   *   *
289   * Tcl_CdObjCmd --   * Tcl_CdObjCmd --
290   *   *
291   *      This procedure is invoked to process the "cd" Tcl command.   *      This procedure is invoked to process the "cd" Tcl command.
292   *      See the user documentation for details on what it does.   *      See the user documentation for details on what it does.
293   *   *
294   * Results:   * Results:
295   *      A standard Tcl result.   *      A standard Tcl result.
296   *   *
297   * Side effects:   * Side effects:
298   *      See the user documentation.   *      See the user documentation.
299   *   *
300   *----------------------------------------------------------------------   *----------------------------------------------------------------------
301   */   */
302    
303          /* ARGSUSED */          /* ARGSUSED */
304  int  int
305  Tcl_CdObjCmd(dummy, interp, objc, objv)  Tcl_CdObjCmd(dummy, interp, objc, objv)
306      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
307      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
308      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
309      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
310  {  {
311      char *dirName;      char *dirName;
312      Tcl_DString ds;      Tcl_DString ds;
313      int result;      int result;
314    
315      if (objc > 2) {      if (objc > 2) {
316          Tcl_WrongNumArgs(interp, 1, objv, "?dirName?");          Tcl_WrongNumArgs(interp, 1, objv, "?dirName?");
317          return TCL_ERROR;          return TCL_ERROR;
318      }      }
319    
320      if (objc == 2) {      if (objc == 2) {
321          dirName = Tcl_GetString(objv[1]);          dirName = Tcl_GetString(objv[1]);
322      } else {      } else {
323          dirName = "~";          dirName = "~";
324      }      }
325      if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) {      if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) {
326          return TCL_ERROR;          return TCL_ERROR;
327      }      }
328    
329      result = Tcl_Chdir(Tcl_DStringValue(&ds));      result = Tcl_Chdir(Tcl_DStringValue(&ds));
330      Tcl_DStringFree(&ds);      Tcl_DStringFree(&ds);
331    
332      if (result != 0) {      if (result != 0) {
333          Tcl_AppendResult(interp, "couldn't change working directory to \"",          Tcl_AppendResult(interp, "couldn't change working directory to \"",
334                  dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);                  dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
335          return TCL_ERROR;          return TCL_ERROR;
336      }      }
337      return TCL_OK;      return TCL_OK;
338  }  }
339    
340  /*  /*
341   *----------------------------------------------------------------------   *----------------------------------------------------------------------
342   *   *
343   * Tcl_ConcatObjCmd --   * Tcl_ConcatObjCmd --
344   *   *
345   *      This object-based procedure is invoked to process the "concat" Tcl   *      This object-based procedure is invoked to process the "concat" Tcl
346   *      command. See the user documentation for details on what it does.   *      command. See the user documentation for details on what it does.
347   *   *
348   * Results:   * Results:
349   *      A standard Tcl object result.   *      A standard Tcl object result.
350   *   *
351   * Side effects:   * Side effects:
352   *      See the user documentation.   *      See the user documentation.
353   *   *
354   *----------------------------------------------------------------------   *----------------------------------------------------------------------
355   */   */
356    
357          /* ARGSUSED */          /* ARGSUSED */
358  int  int
359  Tcl_ConcatObjCmd(dummy, interp, objc, objv)  Tcl_ConcatObjCmd(dummy, interp, objc, objv)
360      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
361      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
362      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
363      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
364  {  {
365      if (objc >= 2) {      if (objc >= 2) {
366          Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));          Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
367      }      }
368      return TCL_OK;      return TCL_OK;
369  }  }
370    
371  /*  /*
372   *----------------------------------------------------------------------   *----------------------------------------------------------------------
373   *   *
374   * Tcl_ContinueObjCmd -   * Tcl_ContinueObjCmd -
375   *   *
376   *      This procedure is invoked to process the "continue" Tcl command.   *      This procedure is invoked to process the "continue" Tcl command.
377   *      See the user documentation for details on what it does.   *      See the user documentation for details on what it does.
378   *   *
379   *      With the bytecode compiler, this procedure is only called when   *      With the bytecode compiler, this procedure is only called when
380   *      a command name is computed at runtime, and is "continue" or the name   *      a command name is computed at runtime, and is "continue" or the name
381   *      to which "continue" was renamed: e.g., "set z continue; $z"   *      to which "continue" was renamed: e.g., "set z continue; $z"
382   *   *
383   * Results:   * Results:
384   *      A standard Tcl result.   *      A standard Tcl result.
385   *   *
386   * Side effects:   * Side effects:
387   *      See the user documentation.   *      See the user documentation.
388   *   *
389   *----------------------------------------------------------------------   *----------------------------------------------------------------------
390   */   */
391    
392          /* ARGSUSED */          /* ARGSUSED */
393  int  int
394  Tcl_ContinueObjCmd(dummy, interp, objc, objv)  Tcl_ContinueObjCmd(dummy, interp, objc, objv)
395      ClientData dummy;                   /* Not used. */      ClientData dummy;                   /* Not used. */
396      Tcl_Interp *interp;                 /* Current interpreter. */      Tcl_Interp *interp;                 /* Current interpreter. */
397      int objc;                           /* Number of arguments. */      int objc;                           /* Number of arguments. */
398      Tcl_Obj *CONST objv[];              /* Argument objects. */      Tcl_Obj *CONST objv[];              /* Argument objects. */
399  {  {
400      if (objc != 1) {      if (objc != 1) {
401          Tcl_WrongNumArgs(interp, 1, objv, NULL);          Tcl_WrongNumArgs(interp, 1, objv, NULL);
402          return TCL_ERROR;          return TCL_ERROR;
403      }      }
404      return TCL_CONTINUE;      return TCL_CONTINUE;
405  }  }
406    
407  /*  /*
408   *----------------------------------------------------------------------   *----------------------------------------------------------------------
409   *   *
410   * Tcl_EncodingObjCmd --   * Tcl_EncodingObjCmd --
411   *   *
412   *      This command manipulates encodings.   *      This command manipulates encodings.
413   *   *
414   * Results:   * Results:
415   *      A standard Tcl result.   *      A standard Tcl result.
416   *   *
417   * Side effects:   * Side effects:
418   *      See the user documentation.   *      See the user documentation.
419   *   *
420   *----------------------------------------------------------------------   *----------------------------------------------------------------------
421   */   */
422    
423  int  int
424  Tcl_EncodingObjCmd(dummy, interp, objc, objv)  Tcl_EncodingObjCmd(dummy, interp, objc, objv)
425      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
426      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
427      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
428      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
429  {  {
430      int index, length;      int index, length;
431      Tcl_Encoding encoding;      Tcl_Encoding encoding;
432      char *string;      char *string;
433      Tcl_DString ds;      Tcl_DString ds;
434      Tcl_Obj *resultPtr;      Tcl_Obj *resultPtr;
435    
436      static char *optionStrings[] = {      static char *optionStrings[] = {
437          "convertfrom", "convertto", "names", "system",          "convertfrom", "convertto", "names", "system",
438          NULL          NULL
439      };      };
440      enum options {      enum options {
441          ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM          ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM
442      };      };
443    
444      if (objc < 2) {      if (objc < 2) {
445          Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");          Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
446          return TCL_ERROR;          return TCL_ERROR;
447      }      }
448      if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,      if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
449              &index) != TCL_OK) {              &index) != TCL_OK) {
450          return TCL_ERROR;          return TCL_ERROR;
451      }      }
452    
453      switch ((enum options) index) {      switch ((enum options) index) {
454          case ENC_CONVERTTO:          case ENC_CONVERTTO:
455          case ENC_CONVERTFROM: {          case ENC_CONVERTFROM: {
456              char *name;              char *name;
457              Tcl_Obj *data;              Tcl_Obj *data;
458              if (objc == 3) {              if (objc == 3) {
459                  name = NULL;                  name = NULL;
460                  data = objv[2];                  data = objv[2];
461              } else if (objc == 4) {              } else if (objc == 4) {
462                  name = Tcl_GetString(objv[2]);                  name = Tcl_GetString(objv[2]);
463                  data = objv[3];                  data = objv[3];
464              } else {              } else {
465                  Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");                  Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
466                  return TCL_ERROR;                  return TCL_ERROR;
467              }              }
468                            
469              encoding = Tcl_GetEncoding(interp, name);              encoding = Tcl_GetEncoding(interp, name);
470              if (!encoding) {              if (!encoding) {
471                  return TCL_ERROR;                  return TCL_ERROR;
472              }              }
473    
474              if ((enum options) index == ENC_CONVERTFROM) {              if ((enum options) index == ENC_CONVERTFROM) {
475                  /*                  /*
476                   * Treat the string as binary data.                   * Treat the string as binary data.
477                   */                   */
478    
479                  string = (char *) Tcl_GetByteArrayFromObj(data, &length);                  string = (char *) Tcl_GetByteArrayFromObj(data, &length);
480                  Tcl_ExternalToUtfDString(encoding, string, length, &ds);                  Tcl_ExternalToUtfDString(encoding, string, length, &ds);
481    
482                  /*                  /*
483                   * Note that we cannot use Tcl_DStringResult here because                   * Note that we cannot use Tcl_DStringResult here because
484                   * it will truncate the string at the first null byte.                   * it will truncate the string at the first null byte.
485                   */                   */
486    
487                  Tcl_SetStringObj(Tcl_GetObjResult(interp),                  Tcl_SetStringObj(Tcl_GetObjResult(interp),
488                          Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));                          Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
489                  Tcl_DStringFree(&ds);                  Tcl_DStringFree(&ds);
490              } else {              } else {
491                  /*                  /*
492                   * Store the result as binary data.                   * Store the result as binary data.
493                   */                   */
494    
495                  string = Tcl_GetStringFromObj(data, &length);                  string = Tcl_GetStringFromObj(data, &length);
496                  Tcl_UtfToExternalDString(encoding, string, length, &ds);                  Tcl_UtfToExternalDString(encoding, string, length, &ds);
497                  resultPtr = Tcl_GetObjResult(interp);                  resultPtr = Tcl_GetObjResult(interp);
498                  Tcl_SetByteArrayObj(resultPtr,                  Tcl_SetByteArrayObj(resultPtr,
499                          (unsigned char *) Tcl_DStringValue(&ds),                          (unsigned char *) Tcl_DStringValue(&ds),
500                          Tcl_DStringLength(&ds));                          Tcl_DStringLength(&ds));
501                  Tcl_DStringFree(&ds);                  Tcl_DStringFree(&ds);
502              }              }
503    
504              Tcl_FreeEncoding(encoding);              Tcl_FreeEncoding(encoding);
505              break;              break;
506          }          }
507          case ENC_NAMES: {          case ENC_NAMES: {
508              if (objc > 2) {              if (objc > 2) {
509                  Tcl_WrongNumArgs(interp, 2, objv, NULL);                  Tcl_WrongNumArgs(interp, 2, objv, NULL);
510                  return TCL_ERROR;                  return TCL_ERROR;
511              }              }
512              Tcl_GetEncodingNames(interp);              Tcl_GetEncodingNames(interp);
513              break;              break;
514          }          }
515          case ENC_SYSTEM: {          case ENC_SYSTEM: {
516              if (objc > 3) {              if (objc > 3) {
517                  Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");                  Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
518                  return TCL_ERROR;                  return TCL_ERROR;
519              }              }
520              if (objc == 2) {              if (objc == 2) {
521                  Tcl_SetResult(interp, Tcl_GetEncodingName(NULL), TCL_STATIC);                  Tcl_SetResult(interp, Tcl_GetEncodingName(NULL), TCL_STATIC);
522              } else {              } else {
523                  return Tcl_SetSystemEncoding(interp,                  return Tcl_SetSystemEncoding(interp,
524                          Tcl_GetStringFromObj(objv[2], NULL));                          Tcl_GetStringFromObj(objv[2], NULL));
525              }              }
526              break;              break;
527          }          }
528      }      }
529      return TCL_OK;      return TCL_OK;
530  }  }
531    
532  /*  /*
533   *----------------------------------------------------------------------   *----------------------------------------------------------------------
534   *   *
535   * Tcl_ErrorObjCmd --   * Tcl_ErrorObjCmd --
536   *   *
537   *      This procedure is invoked to process the "error" Tcl command.   *      This procedure is invoked to process the "error" Tcl command.
538   *      See the user documentation for details on what it does.   *      See the user documentation for details on what it does.
539   *   *
540   * Results:   * Results:
541   *      A standard Tcl object result.   *      A standard Tcl object result.
542   *   *
543   * Side effects:   * Side effects:
544   *      See the user documentation.   *      See the user documentation.
545   *   *
546   *----------------------------------------------------------------------   *----------------------------------------------------------------------
547   */   */
548    
549          /* ARGSUSED */          /* ARGSUSED */
550  int  int
551  Tcl_ErrorObjCmd(dummy, interp, objc, objv)  Tcl_ErrorObjCmd(dummy, interp, objc, objv)
552      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
553      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
554      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
555      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
556  {  {
557      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
558      char *info;      char *info;
559      int infoLen;      int infoLen;
560    
561      if ((objc < 2) || (objc > 4)) {      if ((objc < 2) || (objc > 4)) {
562          Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");          Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
563          return TCL_ERROR;          return TCL_ERROR;
564      }      }
565            
566      if (objc >= 3) {            /* process the optional info argument */      if (objc >= 3) {            /* process the optional info argument */
567          info = Tcl_GetStringFromObj(objv[2], &infoLen);          info = Tcl_GetStringFromObj(objv[2], &infoLen);
568          if (*info != 0) {          if (*info != 0) {
569              Tcl_AddObjErrorInfo(interp, info, infoLen);              Tcl_AddObjErrorInfo(interp, info, infoLen);
570              iPtr->flags |= ERR_ALREADY_LOGGED;              iPtr->flags |= ERR_ALREADY_LOGGED;
571          }          }
572      }      }
573            
574      if (objc == 4) {      if (objc == 4) {
575          Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY);          Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY);
576          iPtr->flags |= ERROR_CODE_SET;          iPtr->flags |= ERROR_CODE_SET;
577      }      }
578            
579      Tcl_SetObjResult(interp, objv[1]);      Tcl_SetObjResult(interp, objv[1]);
580      return TCL_ERROR;      return TCL_ERROR;
581  }  }
582    
583  /*  /*
584   *----------------------------------------------------------------------   *----------------------------------------------------------------------
585   *   *
586   * Tcl_EvalObjCmd --   * Tcl_EvalObjCmd --
587   *   *
588   *      This object-based procedure is invoked to process the "eval" Tcl   *      This object-based procedure is invoked to process the "eval" Tcl
589   *      command. See the user documentation for details on what it does.   *      command. See the user documentation for details on what it does.
590   *   *
591   * Results:   * Results:
592   *      A standard Tcl object result.   *      A standard Tcl object result.
593   *   *
594   * Side effects:   * Side effects:
595   *      See the user documentation.   *      See the user documentation.
596   *   *
597   *----------------------------------------------------------------------   *----------------------------------------------------------------------
598   */   */
599    
600          /* ARGSUSED */          /* ARGSUSED */
601  int  int
602  Tcl_EvalObjCmd(dummy, interp, objc, objv)  Tcl_EvalObjCmd(dummy, interp, objc, objv)
603      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
604      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
605      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
606      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
607  {  {
608      int result;      int result;
609      register Tcl_Obj *objPtr;      register Tcl_Obj *objPtr;
610    
611      if (objc < 2) {      if (objc < 2) {
612          Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");          Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
613          return TCL_ERROR;          return TCL_ERROR;
614      }      }
615            
616      if (objc == 2) {      if (objc == 2) {
617          result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);          result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);
618      } else {      } else {
619          /*          /*
620           * More than one argument: concatenate them together with spaces           * More than one argument: concatenate them together with spaces
621           * between, then evaluate the result.  Tcl_EvalObjEx will delete           * between, then evaluate the result.  Tcl_EvalObjEx will delete
622           * the object when it decrements its refcount after eval'ing it.           * the object when it decrements its refcount after eval'ing it.
623           */           */
624          objPtr = Tcl_ConcatObj(objc-1, objv+1);          objPtr = Tcl_ConcatObj(objc-1, objv+1);
625          result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);          result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
626      }      }
627      if (result == TCL_ERROR) {      if (result == TCL_ERROR) {
628          char msg[32 + TCL_INTEGER_SPACE];          char msg[32 + TCL_INTEGER_SPACE];
629    
630          sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);          sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
631          Tcl_AddObjErrorInfo(interp, msg, -1);          Tcl_AddObjErrorInfo(interp, msg, -1);
632      }      }
633      return result;      return result;
634  }  }
635    
636  /*  /*
637   *----------------------------------------------------------------------   *----------------------------------------------------------------------
638   *   *
639   * Tcl_ExitObjCmd --   * Tcl_ExitObjCmd --
640   *   *
641   *      This procedure is invoked to process the "exit" Tcl command.   *      This procedure is invoked to process the "exit" Tcl command.
642   *      See the user documentation for details on what it does.   *      See the user documentation for details on what it does.
643   *   *
644   * Results:   * Results:
645   *      A standard Tcl object result.   *      A standard Tcl object result.
646   *   *
647   * Side effects:   * Side effects:
648   *      See the user documentation.   *      See the user documentation.
649   *   *
650   *----------------------------------------------------------------------   *----------------------------------------------------------------------
651   */   */
652    
653          /* ARGSUSED */          /* ARGSUSED */
654  int  int
655  Tcl_ExitObjCmd(dummy, interp, objc, objv)  Tcl_ExitObjCmd(dummy, interp, objc, objv)
656      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
657      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
658      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
659      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
660  {  {
661      int value;      int value;
662    
663      if ((objc != 1) && (objc != 2)) {      if ((objc != 1) && (objc != 2)) {
664          Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");          Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
665          return TCL_ERROR;          return TCL_ERROR;
666      }      }
667            
668      if (objc == 1) {      if (objc == 1) {
669          value = 0;          value = 0;
670      } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {      } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
671          return TCL_ERROR;          return TCL_ERROR;
672      }      }
673      Tcl_Exit(value);      Tcl_Exit(value);
674      /*NOTREACHED*/      /*NOTREACHED*/
675      return TCL_OK;                      /* Better not ever reach this! */      return TCL_OK;                      /* Better not ever reach this! */
676  }  }
677    
678  /*  /*
679   *----------------------------------------------------------------------   *----------------------------------------------------------------------
680   *   *
681   * Tcl_ExprObjCmd --   * Tcl_ExprObjCmd --
682   *   *
683   *      This object-based procedure is invoked to process the "expr" Tcl   *      This object-based procedure is invoked to process the "expr" Tcl
684   *      command. See the user documentation for details on what it does.   *      command. See the user documentation for details on what it does.
685   *   *
686   *      With the bytecode compiler, this procedure is called in two   *      With the bytecode compiler, this procedure is called in two
687   *      circumstances: 1) to execute expr commands that are too complicated   *      circumstances: 1) to execute expr commands that are too complicated
688   *      or too unsafe to try compiling directly into an inline sequence of   *      or too unsafe to try compiling directly into an inline sequence of
689   *      instructions, and 2) to execute commands where the command name is   *      instructions, and 2) to execute commands where the command name is
690   *      computed at runtime and is "expr" or the name to which "expr" was   *      computed at runtime and is "expr" or the name to which "expr" was
691   *      renamed (e.g., "set z expr; $z 2+3")   *      renamed (e.g., "set z expr; $z 2+3")
692   *   *
693   * Results:   * Results:
694   *      A standard Tcl object result.   *      A standard Tcl object result.
695   *   *
696   * Side effects:   * Side effects:
697   *      See the user documentation.   *      See the user documentation.
698   *   *
699   *----------------------------------------------------------------------   *----------------------------------------------------------------------
700   */   */
701    
702          /* ARGSUSED */          /* ARGSUSED */
703  int  int
704  Tcl_ExprObjCmd(dummy, interp, objc, objv)  Tcl_ExprObjCmd(dummy, interp, objc, objv)
705      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
706      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
707      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
708      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
709  {          {        
710      register Tcl_Obj *objPtr;      register Tcl_Obj *objPtr;
711      Tcl_Obj *resultPtr;      Tcl_Obj *resultPtr;
712      register char *bytes;      register char *bytes;
713      int length, i, result;      int length, i, result;
714    
715      if (objc < 2) {      if (objc < 2) {
716          Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");          Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
717          return TCL_ERROR;          return TCL_ERROR;
718      }      }
719    
720      if (objc == 2) {      if (objc == 2) {
721          result = Tcl_ExprObj(interp, objv[1], &resultPtr);          result = Tcl_ExprObj(interp, objv[1], &resultPtr);
722          if (result == TCL_OK) {          if (result == TCL_OK) {
723              Tcl_SetObjResult(interp, resultPtr);              Tcl_SetObjResult(interp, resultPtr);
724              Tcl_DecrRefCount(resultPtr);  /* done with the result object */              Tcl_DecrRefCount(resultPtr);  /* done with the result object */
725          }          }
726          return result;          return result;
727      }      }
728    
729      /*      /*
730       * Create a new object holding the concatenated argument strings.       * Create a new object holding the concatenated argument strings.
731       */       */
732    
733      bytes = Tcl_GetStringFromObj(objv[1], &length);      bytes = Tcl_GetStringFromObj(objv[1], &length);
734      objPtr = Tcl_NewStringObj(bytes, length);      objPtr = Tcl_NewStringObj(bytes, length);
735      Tcl_IncrRefCount(objPtr);      Tcl_IncrRefCount(objPtr);
736      for (i = 2;  i < objc;  i++) {      for (i = 2;  i < objc;  i++) {
737          Tcl_AppendToObj(objPtr, " ", 1);          Tcl_AppendToObj(objPtr, " ", 1);
738          bytes = Tcl_GetStringFromObj(objv[i], &length);          bytes = Tcl_GetStringFromObj(objv[i], &length);
739          Tcl_AppendToObj(objPtr, bytes, length);          Tcl_AppendToObj(objPtr, bytes, length);
740      }      }
741    
742      /*      /*
743       * Evaluate the concatenated string object.       * Evaluate the concatenated string object.
744       */       */
745    
746      result = Tcl_ExprObj(interp, objPtr, &resultPtr);      result = Tcl_ExprObj(interp, objPtr, &resultPtr);
747      if (result == TCL_OK) {      if (result == TCL_OK) {
748          Tcl_SetObjResult(interp, resultPtr);          Tcl_SetObjResult(interp, resultPtr);
749          Tcl_DecrRefCount(resultPtr);  /* done with the result object */          Tcl_DecrRefCount(resultPtr);  /* done with the result object */
750      }      }
751    
752      /*      /*
753       * Free allocated resources.       * Free allocated resources.
754       */       */
755            
756      Tcl_DecrRefCount(objPtr);      Tcl_DecrRefCount(objPtr);
757      return result;      return result;
758  }  }
759    
760  /*  /*
761   *----------------------------------------------------------------------   *----------------------------------------------------------------------
762   *   *
763   * Tcl_FileObjCmd --   * Tcl_FileObjCmd --
764   *   *
765   *      This procedure is invoked to process the "file" Tcl command.   *      This procedure is invoked to process the "file" Tcl command.
766   *      See the user documentation for details on what it does.   *      See the user documentation for details on what it does.
767   *      PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH   *      PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
768   *      EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.   *      EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.
769   *   *
770   * Results:   * Results:
771   *      A standard Tcl result.   *      A standard Tcl result.
772   *   *
773   * Side effects:   * Side effects:
774   *      See the user documentation.   *      See the user documentation.
775   *   *
776   *----------------------------------------------------------------------   *----------------------------------------------------------------------
777   */   */
778    
779          /* ARGSUSED */          /* ARGSUSED */
780  int  int
781  Tcl_FileObjCmd(dummy, interp, objc, objv)  Tcl_FileObjCmd(dummy, interp, objc, objv)
782      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
783      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
784      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
785      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
786  {  {
787      Tcl_Obj *resultPtr;      Tcl_Obj *resultPtr;
788      int index;      int index;
789    
790  /*  /*
791   * This list of constants should match the fileOption string array below.   * This list of constants should match the fileOption string array below.
792   */   */
793    
794      static char *fileOptions[] = {      static char *fileOptions[] = {
795          "atime",        "attributes",   "channels",     "copy",          "atime",        "attributes",   "channels",     "copy",
796          "delete",          "delete",
797          "dirname",      "executable",   "exists",       "extension",          "dirname",      "executable",   "exists",       "extension",
798          "isdirectory",  "isfile",       "join",         "lstat",          "isdirectory",  "isfile",       "join",         "lstat",
799          "mtime",        "mkdir",        "nativename",   "owned",          "mtime",        "mkdir",        "nativename",   "owned",
800          "pathtype",     "readable",     "readlink",     "rename",          "pathtype",     "readable",     "readlink",     "rename",
801          "rootname",     "size",         "split",        "stat",          "rootname",     "size",         "split",        "stat",
802          "tail",         "type",         "volumes",      "writable",          "tail",         "type",         "volumes",      "writable",
803          (char *) NULL          (char *) NULL
804      };      };
805      enum options {      enum options {
806          FILE_ATIME,     FILE_ATTRIBUTES, FILE_CHANNELS, FILE_COPY,          FILE_ATIME,     FILE_ATTRIBUTES, FILE_CHANNELS, FILE_COPY,
807          FILE_DELETE,          FILE_DELETE,
808          FILE_DIRNAME,   FILE_EXECUTABLE, FILE_EXISTS,   FILE_EXTENSION,          FILE_DIRNAME,   FILE_EXECUTABLE, FILE_EXISTS,   FILE_EXTENSION,
809          FILE_ISDIRECTORY, FILE_ISFILE,  FILE_JOIN,      FILE_LSTAT,          FILE_ISDIRECTORY, FILE_ISFILE,  FILE_JOIN,      FILE_LSTAT,
810          FILE_MTIME,     FILE_MKDIR,     FILE_NATIVENAME, FILE_OWNED,          FILE_MTIME,     FILE_MKDIR,     FILE_NATIVENAME, FILE_OWNED,
811          FILE_PATHTYPE,  FILE_READABLE,  FILE_READLINK,  FILE_RENAME,          FILE_PATHTYPE,  FILE_READABLE,  FILE_READLINK,  FILE_RENAME,
812          FILE_ROOTNAME,  FILE_SIZE,      FILE_SPLIT,     FILE_STAT,          FILE_ROOTNAME,  FILE_SIZE,      FILE_SPLIT,     FILE_STAT,
813          FILE_TAIL,      FILE_TYPE,      FILE_VOLUMES,   FILE_WRITABLE          FILE_TAIL,      FILE_TYPE,      FILE_VOLUMES,   FILE_WRITABLE
814      };      };
815    
816      if (objc < 2) {      if (objc < 2) {
817          Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");          Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
818          return TCL_ERROR;          return TCL_ERROR;
819      }      }
820      if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,      if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
821              &index) != TCL_OK) {              &index) != TCL_OK) {
822          return TCL_ERROR;          return TCL_ERROR;
823      }      }
824    
825      resultPtr = Tcl_GetObjResult(interp);      resultPtr = Tcl_GetObjResult(interp);
826      switch ((enum options) index) {      switch ((enum options) index) {
827          case FILE_ATIME: {          case FILE_ATIME: {
828              struct stat buf;              struct stat buf;
829              char *fileName;              char *fileName;
830              struct utimbuf tval;              struct utimbuf tval;
831    
832              if ((objc < 3) || (objc > 4)) {              if ((objc < 3) || (objc > 4)) {
833                  Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");                  Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
834                  return TCL_ERROR;                  return TCL_ERROR;
835              }              }
836              if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {              if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
837                  return TCL_ERROR;                  return TCL_ERROR;
838              }              }
839              if (objc == 4) {              if (objc == 4) {
840                  if (Tcl_GetLongFromObj(interp, objv[3],                  if (Tcl_GetLongFromObj(interp, objv[3],
841                          (long*)(&buf.st_atime)) != TCL_OK) {                          (long*)(&buf.st_atime)) != TCL_OK) {
842                      return TCL_ERROR;                      return TCL_ERROR;
843                  }                  }
844                  tval.actime = buf.st_atime;                  tval.actime = buf.st_atime;
845                  tval.modtime = buf.st_mtime;                  tval.modtime = buf.st_mtime;
846                  fileName = Tcl_GetString(objv[2]);                  fileName = Tcl_GetString(objv[2]);
847                  if (utime(fileName, &tval) != 0) {                  if (utime(fileName, &tval) != 0) {
848                      Tcl_AppendStringsToObj(resultPtr,                      Tcl_AppendStringsToObj(resultPtr,
849                              "could not set access time for file \"",                              "could not set access time for file \"",
850                              fileName, "\": ",                              fileName, "\": ",
851                              Tcl_PosixError(interp), (char *) NULL);                              Tcl_PosixError(interp), (char *) NULL);
852                      return TCL_ERROR;                      return TCL_ERROR;
853                  }                  }
854                  /*                  /*
855                   * Do another stat to ensure that the we return the                   * Do another stat to ensure that the we return the
856                   * new recognized atime - hopefully the same as the                   * new recognized atime - hopefully the same as the
857                   * one we sent in.  However, fs's like FAT don't                   * one we sent in.  However, fs's like FAT don't
858                   * even know what atime is.                   * even know what atime is.
859                   */                   */
860                  if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {                  if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
861                      return TCL_ERROR;                      return TCL_ERROR;
862                  }                  }
863              }              }
864              Tcl_SetLongObj(resultPtr, (long) buf.st_atime);              Tcl_SetLongObj(resultPtr, (long) buf.st_atime);
865              return TCL_OK;              return TCL_OK;
866          }          }
867          case FILE_ATTRIBUTES: {          case FILE_ATTRIBUTES: {
868              return TclFileAttrsCmd(interp, objc, objv);              return TclFileAttrsCmd(interp, objc, objv);
869          }          }
870          case FILE_CHANNELS: {          case FILE_CHANNELS: {
871              if ((objc < 2) || (objc > 3)) {              if ((objc < 2) || (objc > 3)) {
872                  Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");                  Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
873                  return TCL_ERROR;                  return TCL_ERROR;
874              }              }
875              return Tcl_GetChannelNamesEx(interp,              return Tcl_GetChannelNamesEx(interp,
876                      ((objc == 2) ? NULL : Tcl_GetString(objv[2])));                      ((objc == 2) ? NULL : Tcl_GetString(objv[2])));
877          }          }
878          case FILE_COPY: {          case FILE_COPY: {
879              int result;              int result;
880              char **argv;              char **argv;
881    
882              argv = StringifyObjects(objc, objv);              argv = StringifyObjects(objc, objv);
883              result = TclFileCopyCmd(interp, objc, argv);              result = TclFileCopyCmd(interp, objc, argv);
884              ckfree((char *) argv);              ckfree((char *) argv);
885              return result;              return result;
886          }                    }          
887          case FILE_DELETE: {          case FILE_DELETE: {
888              int result;              int result;
889              char **argv;              char **argv;
890    
891              argv = StringifyObjects(objc, objv);              argv = StringifyObjects(objc, objv);
892              result = TclFileDeleteCmd(interp, objc, argv);              result = TclFileDeleteCmd(interp, objc, argv);
893              ckfree((char *) argv);              ckfree((char *) argv);
894              return result;              return result;
895          }          }
896          case FILE_DIRNAME: {          case FILE_DIRNAME: {
897              int argc;              int argc;
898              char **argv;              char **argv;
899    
900              if (objc != 3) {              if (objc != 3) {
901                  goto only3Args;                  goto only3Args;
902              }              }
903              if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) {              if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) {
904                  return TCL_ERROR;                  return TCL_ERROR;
905              }              }
906    
907              /*              /*
908               * Return all but the last component.  If there is only one               * Return all but the last component.  If there is only one
909               * component, return it if the path was non-relative, otherwise               * component, return it if the path was non-relative, otherwise
910               * return the current directory.               * return the current directory.
911               */               */
912    
913              if (argc > 1) {              if (argc > 1) {
914                  Tcl_DString ds;                  Tcl_DString ds;
915    
916                  Tcl_DStringInit(&ds);                  Tcl_DStringInit(&ds);
917                  Tcl_JoinPath(argc - 1, argv, &ds);                  Tcl_JoinPath(argc - 1, argv, &ds);
918                  Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds),                  Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds),
919                          Tcl_DStringLength(&ds));                          Tcl_DStringLength(&ds));
920                  Tcl_DStringFree(&ds);                  Tcl_DStringFree(&ds);
921              } else if ((argc == 0)              } else if ((argc == 0)
922                      || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {                      || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
923                  Tcl_SetStringObj(resultPtr,                  Tcl_SetStringObj(resultPtr,
924                          ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1);                          ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1);
925              } else {              } else {
926                  Tcl_SetStringObj(resultPtr, argv[0], -1);                  Tcl_SetStringObj(resultPtr, argv[0], -1);
927              }              }
928              ckfree((char *) argv);              ckfree((char *) argv);
929              return TCL_OK;              return TCL_OK;
930          }          }
931          case FILE_EXECUTABLE: {          case FILE_EXECUTABLE: {
932              if (objc != 3) {              if (objc != 3) {
933                  goto only3Args;                  goto only3Args;
934              }              }
935              return CheckAccess(interp, objv[2], X_OK);              return CheckAccess(interp, objv[2], X_OK);
936          }          }
937          case FILE_EXISTS: {          case FILE_EXISTS: {
938              if (objc != 3) {              if (objc != 3) {
939                  goto only3Args;                  goto only3Args;
940              }              }
941              return CheckAccess(interp, objv[2], F_OK);              return CheckAccess(interp, objv[2], F_OK);
942          }          }
943          case FILE_EXTENSION: {          case FILE_EXTENSION: {
944              char *fileName, *extension;              char *fileName, *extension;
945              if (objc != 3) {              if (objc != 3) {
946                  goto only3Args;                  goto only3Args;
947              }              }
948              fileName = Tcl_GetString(objv[2]);              fileName = Tcl_GetString(objv[2]);
949              extension = TclGetExtension(fileName);              extension = TclGetExtension(fileName);
950              if (extension != NULL) {              if (extension != NULL) {
951                  Tcl_SetStringObj(resultPtr, extension, -1);                  Tcl_SetStringObj(resultPtr, extension, -1);
952              }              }
953              return TCL_OK;              return TCL_OK;
954          }          }
955          case FILE_ISDIRECTORY: {          case FILE_ISDIRECTORY: {
956              int value;              int value;
957              struct stat buf;              struct stat buf;
958    
959              if (objc != 3) {              if (objc != 3) {
960                  goto only3Args;                  goto only3Args;
961              }              }
962              value = 0;              value = 0;
963              if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {              if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {
964                  value = S_ISDIR(buf.st_mode);                  value = S_ISDIR(buf.st_mode);
965              }              }
966              Tcl_SetBooleanObj(resultPtr, value);              Tcl_SetBooleanObj(resultPtr, value);
967              return TCL_OK;              return TCL_OK;
968          }          }
969          case FILE_ISFILE: {          case FILE_ISFILE: {
970              int value;              int value;
971              struct stat buf;              struct stat buf;
972                            
973              if (objc != 3) {              if (objc != 3) {
974                  goto only3Args;                  goto only3Args;
975              }              }
976              value = 0;              value = 0;
977              if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {              if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {
978                  value = S_ISREG(buf.st_mode);                  value = S_ISREG(buf.st_mode);
979              }              }
980              Tcl_SetBooleanObj(resultPtr, value);              Tcl_SetBooleanObj(resultPtr, value);
981              return TCL_OK;              return TCL_OK;
982          }          }
983          case FILE_JOIN: {          case FILE_JOIN: {
984              char **argv;              char **argv;
985              Tcl_DString ds;              Tcl_DString ds;
986    
987              if (objc < 3) {              if (objc < 3) {
988                  Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");                  Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
989                  return TCL_ERROR;                  return TCL_ERROR;
990              }              }
991              argv = StringifyObjects(objc - 2, objv + 2);              argv = StringifyObjects(objc - 2, objv + 2);
992              Tcl_DStringInit(&ds);              Tcl_DStringInit(&ds);
993              Tcl_JoinPath(objc - 2, argv, &ds);              Tcl_JoinPath(objc - 2, argv, &ds);
994              Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds),              Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds),
995                      Tcl_DStringLength(&ds));                      Tcl_DStringLength(&ds));
996              Tcl_DStringFree(&ds);              Tcl_DStringFree(&ds);
997              ckfree((char *) argv);              ckfree((char *) argv);
998              return TCL_OK;              return TCL_OK;
999          }          }
1000          case FILE_LSTAT: {          case FILE_LSTAT: {
1001              char *varName;              char *varName;
1002              struct stat buf;              struct stat buf;
1003    
1004              if (objc != 4) {              if (objc != 4) {
1005                  Tcl_WrongNumArgs(interp, 2, objv, "name varName");                  Tcl_WrongNumArgs(interp, 2, objv, "name varName");
1006                  return TCL_ERROR;                  return TCL_ERROR;
1007              }              }
1008              if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) {              if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) {
1009                  return TCL_ERROR;                  return TCL_ERROR;
1010              }              }
1011              varName = Tcl_GetString(objv[3]);              varName = Tcl_GetString(objv[3]);
1012              return StoreStatData(interp, varName, &buf);              return StoreStatData(interp, varName, &buf);
1013          }          }
1014          case FILE_MTIME: {          case FILE_MTIME: {
1015              struct stat buf;              struct stat buf;
1016              char *fileName;              char *fileName;
1017              struct utimbuf tval;              struct utimbuf tval;
1018    
1019              if ((objc < 3) || (objc > 4)) {              if ((objc < 3) || (objc > 4)) {
1020                  Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");                  Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
1021                  return TCL_ERROR;                  return TCL_ERROR;
1022              }              }
1023              if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {              if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
1024                  return TCL_ERROR;                  return TCL_ERROR;
1025              }              }
1026              if (objc == 4) {              if (objc == 4) {
1027                  if (Tcl_GetLongFromObj(interp, objv[3],                  if (Tcl_GetLongFromObj(interp, objv[3],
1028                          (long*)(&buf.st_mtime)) != TCL_OK) {                          (long*)(&buf.st_mtime)) != TCL_OK) {
1029                      return TCL_ERROR;                      return TCL_ERROR;
1030                  }                  }
1031                  tval.actime = buf.st_atime;                  tval.actime = buf.st_atime;
1032                  tval.modtime = buf.st_mtime;                  tval.modtime = buf.st_mtime;
1033                  fileName = Tcl_GetString(objv[2]);                  fileName = Tcl_GetString(objv[2]);
1034                  if (utime(fileName, &tval) != 0) {                  if (utime(fileName, &tval) != 0) {
1035                      Tcl_AppendStringsToObj(resultPtr,                      Tcl_AppendStringsToObj(resultPtr,
1036                              "could not set modification time for file \"",                              "could not set modification time for file \"",
1037                              fileName, "\": ",                              fileName, "\": ",
1038                              Tcl_PosixError(interp), (char *) NULL);                              Tcl_PosixError(interp), (char *) NULL);
1039                      return TCL_ERROR;                      return TCL_ERROR;
1040                  }                  }
1041                  /*                  /*
1042                   * Do another stat to ensure that the we return the                   * Do another stat to ensure that the we return the
1043                   * new recognized atime - hopefully the same as the                   * new recognized atime - hopefully the same as the
1044                   * one we sent in.  However, fs's like FAT don't                   * one we sent in.  However, fs's like FAT don't
1045                   * even know what atime is.                   * even know what atime is.
1046                   */                   */
1047                  if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {                  if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
1048                      return TCL_ERROR;                      return TCL_ERROR;
1049                  }                  }
1050              }              }
1051              Tcl_SetLongObj(resultPtr, (long) buf.st_mtime);              Tcl_SetLongObj(resultPtr, (long) buf.st_mtime);
1052              return TCL_OK;              return TCL_OK;
1053          }          }
1054          case FILE_MKDIR: {          case FILE_MKDIR: {
1055              char **argv;              char **argv;
1056              int result;              int result;
1057    
1058              if (objc < 3) {              if (objc < 3) {
1059                  Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");                  Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
1060                  return TCL_ERROR;                  return TCL_ERROR;
1061              }              }
1062              argv = StringifyObjects(objc, objv);              argv = StringifyObjects(objc, objv);
1063              result = TclFileMakeDirsCmd(interp, objc, argv);              result = TclFileMakeDirsCmd(interp, objc, argv);
1064              ckfree((char *) argv);              ckfree((char *) argv);
1065              return result;              return result;
1066          }          }
1067          case FILE_NATIVENAME: {          case FILE_NATIVENAME: {
1068              char *fileName;              char *fileName;
1069              Tcl_DString ds;              Tcl_DString ds;
1070    
1071              if (objc != 3) {              if (objc != 3) {
1072                  goto only3Args;                  goto only3Args;
1073              }              }
1074              fileName = Tcl_GetString(objv[2]);              fileName = Tcl_GetString(objv[2]);
1075              fileName = Tcl_TranslateFileName(interp, fileName, &ds);              fileName = Tcl_TranslateFileName(interp, fileName, &ds);
1076              if (fileName == NULL) {              if (fileName == NULL) {
1077                  return TCL_ERROR;                  return TCL_ERROR;
1078              }              }
1079              Tcl_SetStringObj(resultPtr, fileName, Tcl_DStringLength(&ds));              Tcl_SetStringObj(resultPtr, fileName, Tcl_DStringLength(&ds));
1080              Tcl_DStringFree(&ds);              Tcl_DStringFree(&ds);
1081              return TCL_OK;              return TCL_OK;
1082          }          }
1083          case FILE_OWNED: {          case FILE_OWNED: {
1084              int value;              int value;
1085              struct stat buf;              struct stat buf;
1086                            
1087              if (objc != 3) {              if (objc != 3) {
1088                  goto only3Args;                  goto only3Args;
1089              }              }
1090              value = 0;              value = 0;
1091              if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {              if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {
1092                  /*                  /*
1093                   * For Windows and Macintosh, there are no user ids                   * For Windows and Macintosh, there are no user ids
1094                   * associated with a file, so we always return 1.                   * associated with a file, so we always return 1.
1095                   */                   */
1096    
1097  #if (defined(__WIN32__) || defined(MAC_TCL))  #if (defined(__WIN32__) || defined(MAC_TCL))
1098                  value = 1;                  value = 1;
1099  #else  #else
1100                  value = (geteuid() == buf.st_uid);                  value = (geteuid() == buf.st_uid);
1101  #endif  #endif
1102              }                    }      
1103              Tcl_SetBooleanObj(resultPtr, value);              Tcl_SetBooleanObj(resultPtr, value);
1104              return TCL_OK;              return TCL_OK;
1105          }          }
1106          case FILE_PATHTYPE: {          case FILE_PATHTYPE: {
1107              char *fileName;              char *fileName;
1108    
1109              if (objc != 3) {              if (objc != 3) {
1110                  goto only3Args;                  goto only3Args;
1111              }              }
1112              fileName = Tcl_GetString(objv[2]);              fileName = Tcl_GetString(objv[2]);
1113              switch (Tcl_GetPathType(fileName)) {              switch (Tcl_GetPathType(fileName)) {
1114                  case TCL_PATH_ABSOLUTE:                  case TCL_PATH_ABSOLUTE:
1115                      Tcl_SetStringObj(resultPtr, "absolute", -1);                      Tcl_SetStringObj(resultPtr, "absolute", -1);
1116                      break;                      break;
1117                  case TCL_PATH_RELATIVE:                  case TCL_PATH_RELATIVE:
1118                      Tcl_SetStringObj(resultPtr, "relative", -1);                      Tcl_SetStringObj(resultPtr, "relative", -1);
1119                      break;                      break;
1120                  case TCL_PATH_VOLUME_RELATIVE:                  case TCL_PATH_VOLUME_RELATIVE:
1121                      Tcl_SetStringObj(resultPtr, "volumerelative", -1);                      Tcl_SetStringObj(resultPtr, "volumerelative", -1);
1122                      break;                      break;
1123              }              }
1124              return TCL_OK;              return TCL_OK;
1125          }          }
1126          case FILE_READABLE: {          case FILE_READABLE: {
1127              if (objc != 3) {              if (objc != 3) {
1128                  goto only3Args;                  goto only3Args;
1129              }              }
1130              return CheckAccess(interp, objv[2], R_OK);              return CheckAccess(interp, objv[2], R_OK);
1131          }          }
1132          case FILE_READLINK: {          case FILE_READLINK: {
1133              char *fileName, *contents;              char *fileName, *contents;
1134              Tcl_DString name, link;              Tcl_DString name, link;
1135                                    
1136              if (objc != 3) {              if (objc != 3) {
1137                  goto only3Args;                  goto only3Args;
1138              }              }
1139                            
1140              fileName = Tcl_GetString(objv[2]);              fileName = Tcl_GetString(objv[2]);
1141              fileName = Tcl_TranslateFileName(interp, fileName, &name);              fileName = Tcl_TranslateFileName(interp, fileName, &name);
1142              if (fileName == NULL) {              if (fileName == NULL) {
1143                  return TCL_ERROR;                  return TCL_ERROR;
1144              }              }
1145    
1146              /*              /*
1147               * If S_IFLNK isn't defined it means that the machine doesn't               * If S_IFLNK isn't defined it means that the machine doesn't
1148               * support symbolic links, so the file can't possibly be a               * support symbolic links, so the file can't possibly be a
1149               * symbolic link.  Generate an EINVAL error, which is what               * symbolic link.  Generate an EINVAL error, which is what
1150               * happens on machines that do support symbolic links when               * happens on machines that do support symbolic links when
1151               * you invoke readlink on a file that isn't a symbolic link.               * you invoke readlink on a file that isn't a symbolic link.
1152               */               */
1153    
1154  #ifndef S_IFLNK  #ifndef S_IFLNK
1155              contents = NULL;              contents = NULL;
1156              errno = EINVAL;              errno = EINVAL;
1157  #else  #else
1158              contents = TclpReadlink(fileName, &link);              contents = TclpReadlink(fileName, &link);
1159  #endif /* S_IFLNK */  #endif /* S_IFLNK */
1160    
1161              Tcl_DStringFree(&name);              Tcl_DStringFree(&name);
1162              if (contents == NULL) {              if (contents == NULL) {
1163                  Tcl_AppendResult(interp, "could not readlink \"",                  Tcl_AppendResult(interp, "could not readlink \"",
1164                          Tcl_GetString(objv[2]), "\": ",                          Tcl_GetString(objv[2]), "\": ",
1165                          Tcl_PosixError(interp), (char *) NULL);                          Tcl_PosixError(interp), (char *) NULL);
1166                  return TCL_ERROR;                  return TCL_ERROR;
1167              }              }
1168              Tcl_DStringResult(interp, &link);              Tcl_DStringResult(interp, &link);
1169              return TCL_OK;              return TCL_OK;
1170          }          }
1171          case FILE_RENAME: {          case FILE_RENAME: {
1172              int result;              int result;
1173              char **argv;              char **argv;
1174    
1175              argv = StringifyObjects(objc, objv);              argv = StringifyObjects(objc, objv);
1176              result = TclFileRenameCmd(interp, objc, argv);              result = TclFileRenameCmd(interp, objc, argv);
1177              ckfree((char *) argv);              ckfree((char *) argv);
1178              return result;              return result;
1179          }          }
1180          case FILE_ROOTNAME: {          case FILE_ROOTNAME: {
1181              int length;              int length;
1182              char *fileName, *extension;              char *fileName, *extension;
1183                            
1184              if (objc != 3) {              if (objc != 3) {
1185                  goto only3Args;                  goto only3Args;
1186              }              }
1187              fileName = Tcl_GetStringFromObj(objv[2], &length);              fileName = Tcl_GetStringFromObj(objv[2], &length);
1188              extension = TclGetExtension(fileName);              extension = TclGetExtension(fileName);
1189              if (extension == NULL) {              if (extension == NULL) {
1190                  Tcl_SetObjResult(interp, objv[2]);                  Tcl_SetObjResult(interp, objv[2]);
1191              } else {              } else {
1192                  Tcl_SetStringObj(resultPtr, fileName,                  Tcl_SetStringObj(resultPtr, fileName,
1193                          (int) (length - strlen(extension)));                          (int) (length - strlen(extension)));
1194              }              }
1195              return TCL_OK;              return TCL_OK;
1196          }          }
1197          case FILE_SIZE: {          case FILE_SIZE: {
1198              struct stat buf;              struct stat buf;
1199                            
1200              if (objc != 3) {              if (objc != 3) {
1201                  goto only3Args;                  goto only3Args;
1202              }              }
1203              if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {              if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
1204                  return TCL_ERROR;                  return TCL_ERROR;
1205              }              }
1206              Tcl_SetLongObj(resultPtr, (long) buf.st_size);              Tcl_SetLongObj(resultPtr, (long) buf.st_size);
1207              return TCL_OK;              return TCL_OK;
1208          }          }
1209          case FILE_SPLIT: {          case FILE_SPLIT: {
1210              int i, argc;              int i, argc;
1211              char **argv;              char **argv;
1212              char *fileName;              char *fileName;
1213              Tcl_Obj *objPtr;              Tcl_Obj *objPtr;
1214                            
1215              if (objc != 3) {              if (objc != 3) {
1216                  goto only3Args;                  goto only3Args;
1217              }              }
1218              fileName = Tcl_GetString(objv[2]);              fileName = Tcl_GetString(objv[2]);
1219              Tcl_SplitPath(fileName, &argc, &argv);              Tcl_SplitPath(fileName, &argc, &argv);
1220              for (i = 0; i < argc; i++) {              for (i = 0; i < argc; i++) {
1221                  objPtr = Tcl_NewStringObj(argv[i], -1);                  objPtr = Tcl_NewStringObj(argv[i], -1);
1222                  Tcl_ListObjAppendElement(NULL, resultPtr, objPtr);                  Tcl_ListObjAppendElement(NULL, resultPtr, objPtr);
1223              }              }
1224              ckfree((char *) argv);              ckfree((char *) argv);
1225              return TCL_OK;              return TCL_OK;
1226          }          }
1227          case FILE_STAT: {          case FILE_STAT: {
1228              char *varName;              char *varName;
1229              struct stat buf;              struct stat buf;
1230                            
1231              if (objc != 4) {              if (objc != 4) {
1232                  Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");                  Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
1233                  return TCL_ERROR;                  return TCL_ERROR;
1234              }              }
1235              if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {              if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
1236                  return TCL_ERROR;                  return TCL_ERROR;
1237              }              }
1238              varName = Tcl_GetString(objv[3]);              varName = Tcl_GetString(objv[3]);
1239              return StoreStatData(interp, varName, &buf);              return StoreStatData(interp, varName, &buf);
1240          }          }
1241          case FILE_TAIL: {          case FILE_TAIL: {
1242              int argc;              int argc;
1243              char **argv;              char **argv;
1244    
1245              if (objc != 3) {              if (objc != 3) {
1246                  goto only3Args;                  goto only3Args;
1247              }              }
1248              if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) {              if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) {
1249                  return TCL_ERROR;                  return TCL_ERROR;
1250              }              }
1251    
1252              /*              /*
1253               * Return the last component, unless it is the only component,               * Return the last component, unless it is the only component,
1254               * and it is the root of an absolute path.               * and it is the root of an absolute path.
1255               */               */
1256    
1257              if (argc > 0) {              if (argc > 0) {
1258                  if ((argc > 1)                  if ((argc > 1)
1259                          || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {                          || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
1260                      Tcl_SetStringObj(resultPtr, argv[argc - 1], -1);                      Tcl_SetStringObj(resultPtr, argv[argc - 1], -1);
1261                  }                  }
1262              }              }
1263              ckfree((char *) argv);              ckfree((char *) argv);
1264              return TCL_OK;              return TCL_OK;
1265          }          }
1266          case FILE_TYPE: {          case FILE_TYPE: {
1267              struct stat buf;              struct stat buf;
1268    
1269              if (objc != 3) {              if (objc != 3) {
1270                  goto only3Args;                  goto only3Args;
1271              }              }
1272              if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) {              if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) {
1273                  return TCL_ERROR;                  return TCL_ERROR;
1274              }              }
1275              Tcl_SetStringObj(resultPtr,              Tcl_SetStringObj(resultPtr,
1276                      GetTypeFromMode((unsigned short) buf.st_mode), -1);                      GetTypeFromMode((unsigned short) buf.st_mode), -1);
1277              return TCL_OK;              return TCL_OK;
1278          }          }
1279          case FILE_VOLUMES: {          case FILE_VOLUMES: {
1280              if (objc != 2) {              if (objc != 2) {
1281                  Tcl_WrongNumArgs(interp, 2, objv, NULL);                  Tcl_WrongNumArgs(interp, 2, objv, NULL);
1282                  return TCL_ERROR;                  return TCL_ERROR;
1283              }              }
1284              return TclpListVolumes(interp);              return TclpListVolumes(interp);
1285          }          }
1286          case FILE_WRITABLE: {          case FILE_WRITABLE: {
1287              if (objc != 3) {              if (objc != 3) {
1288                  goto only3Args;                  goto only3Args;
1289              }              }
1290              return CheckAccess(interp, objv[2], W_OK);              return CheckAccess(interp, objv[2], W_OK);
1291          }          }
1292      }      }
1293    
1294      only3Args:      only3Args:
1295      Tcl_WrongNumArgs(interp, 2, objv, "name");      Tcl_WrongNumArgs(interp, 2, objv, "name");
1296      return TCL_ERROR;      return TCL_ERROR;
1297  }  }
1298    
1299  /*  /*
1300   *---------------------------------------------------------------------------   *---------------------------------------------------------------------------
1301   *   *
1302   * SplitPath --   * SplitPath --
1303   *   *
1304   *      Utility procedure used by Tcl_FileObjCmd() to split a path.   *      Utility procedure used by Tcl_FileObjCmd() to split a path.
1305   *      Differs from standard Tcl_SplitPath in its handling of home   *      Differs from standard Tcl_SplitPath in its handling of home
1306   *      directories; Tcl_SplitPath preserves the "~" while this   *      directories; Tcl_SplitPath preserves the "~" while this
1307   *      procedure computes the actual full path name.   *      procedure computes the actual full path name.
1308   *   *
1309   * Results:   * Results:
1310   *      The return value is TCL_OK if the path could be split, TCL_ERROR   *      The return value is TCL_OK if the path could be split, TCL_ERROR
1311   *      otherwise.  If TCL_ERROR was returned, an error message is left   *      otherwise.  If TCL_ERROR was returned, an error message is left
1312   *      in interp.  If TCL_OK was returned, *argvPtr is set to a newly   *      in interp.  If TCL_OK was returned, *argvPtr is set to a newly
1313   *      allocated array of strings that represent the individual   *      allocated array of strings that represent the individual
1314   *      directories in the specified path, and *argcPtr is filled with   *      directories in the specified path, and *argcPtr is filled with
1315   *      the length of that array.   *      the length of that array.
1316   *   *
1317   * Side effects:   * Side effects:
1318   *      Memory allocated.  The caller must eventually free this memory   *      Memory allocated.  The caller must eventually free this memory
1319   *      by calling ckfree() on *argvPtr.   *      by calling ckfree() on *argvPtr.
1320   *   *
1321   *---------------------------------------------------------------------------   *---------------------------------------------------------------------------
1322   */   */
1323    
1324  static int  static int
1325  SplitPath(interp, objPtr, argcPtr, argvPtr)  SplitPath(interp, objPtr, argcPtr, argvPtr)
1326      Tcl_Interp *interp;         /* Interp for error return.  May be NULL. */      Tcl_Interp *interp;         /* Interp for error return.  May be NULL. */
1327      Tcl_Obj *objPtr;            /* Path to be split. */      Tcl_Obj *objPtr;            /* Path to be split. */
1328      int *argcPtr;               /* Filled with length of following array. */      int *argcPtr;               /* Filled with length of following array. */
1329      char ***argvPtr;            /* Filled with array of strings representing      char ***argvPtr;            /* Filled with array of strings representing
1330                                   * the elements of the specified path. */                                   * the elements of the specified path. */
1331  {  {
1332      char *fileName;      char *fileName;
1333    
1334      fileName = Tcl_GetString(objPtr);      fileName = Tcl_GetString(objPtr);
1335    
1336      /*      /*
1337       * If there is only one element, and it starts with a tilde,       * If there is only one element, and it starts with a tilde,
1338       * perform tilde substitution and resplit the path.       * perform tilde substitution and resplit the path.
1339       */       */
1340    
1341      Tcl_SplitPath(fileName, argcPtr, argvPtr);      Tcl_SplitPath(fileName, argcPtr, argvPtr);
1342      if ((*argcPtr == 1) && (fileName[0] == '~')) {      if ((*argcPtr == 1) && (fileName[0] == '~')) {
1343          Tcl_DString ds;          Tcl_DString ds;
1344                    
1345          ckfree((char *) *argvPtr);          ckfree((char *) *argvPtr);
1346          fileName = Tcl_TranslateFileName(interp, fileName, &ds);          fileName = Tcl_TranslateFileName(interp, fileName, &ds);
1347          if (fileName == NULL) {          if (fileName == NULL) {
1348              return TCL_ERROR;              return TCL_ERROR;
1349          }          }
1350          Tcl_SplitPath(fileName, argcPtr, argvPtr);          Tcl_SplitPath(fileName, argcPtr, argvPtr);
1351          Tcl_DStringFree(&ds);          Tcl_DStringFree(&ds);
1352      }      }
1353      return TCL_OK;      return TCL_OK;
1354  }  }
1355    
1356  /*  /*
1357   *---------------------------------------------------------------------------   *---------------------------------------------------------------------------
1358   *   *
1359   * CheckAccess --   * CheckAccess --
1360   *   *
1361   *      Utility procedure used by Tcl_FileObjCmd() to query file   *      Utility procedure used by Tcl_FileObjCmd() to query file
1362   *      attributes available through the access() system call.   *      attributes available through the access() system call.
1363   *   *
1364   * Results:   * Results:
1365   *      Always returns TCL_OK.  Sets interp's result to boolean true or   *      Always returns TCL_OK.  Sets interp's result to boolean true or
1366   *      false depending on whether the file has the specified attribute.   *      false depending on whether the file has the specified attribute.
1367   *   *
1368   * Side effects:   * Side effects:
1369   *      None.   *      None.
1370   *   *
1371   *---------------------------------------------------------------------------   *---------------------------------------------------------------------------
1372   */   */
1373        
1374  static int  static int
1375  CheckAccess(interp, objPtr, mode)  CheckAccess(interp, objPtr, mode)
1376      Tcl_Interp *interp;         /* Interp for status return.  Must not be      Tcl_Interp *interp;         /* Interp for status return.  Must not be
1377                                   * NULL. */                                   * NULL. */
1378      Tcl_Obj *objPtr;            /* Name of file to check. */      Tcl_Obj *objPtr;            /* Name of file to check. */
1379      int mode;                   /* Attribute to check; passed as argument to      int mode;                   /* Attribute to check; passed as argument to
1380                                   * access(). */                                   * access(). */
1381  {  {
1382      int value;      int value;
1383      char *fileName;      char *fileName;
1384      Tcl_DString ds;      Tcl_DString ds;
1385            
1386      fileName = Tcl_GetString(objPtr);      fileName = Tcl_GetString(objPtr);
1387      fileName = Tcl_TranslateFileName(interp, fileName, &ds);      fileName = Tcl_TranslateFileName(interp, fileName, &ds);
1388      if (fileName == NULL) {      if (fileName == NULL) {
1389          value = 0;          value = 0;
1390      } else {      } else {
1391          value = (TclAccess(fileName, mode) == 0);          value = (TclAccess(fileName, mode) == 0);
1392          Tcl_DStringFree(&ds);          Tcl_DStringFree(&ds);
1393      }      }
1394      Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);      Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
1395    
1396      return TCL_OK;      return TCL_OK;
1397  }  }
1398    
1399  /*  /*
1400   *---------------------------------------------------------------------------   *---------------------------------------------------------------------------
1401   *   *
1402   * GetStatBuf --   * GetStatBuf --
1403   *   *
1404   *      Utility procedure used by Tcl_FileObjCmd() to query file   *      Utility procedure used by Tcl_FileObjCmd() to query file
1405   *      attributes available through the stat() or lstat() system call.   *      attributes available through the stat() or lstat() system call.
1406   *   *
1407   * Results:   * Results:
1408   *      The return value is TCL_OK if the specified file exists and can   *      The return value is TCL_OK if the specified file exists and can
1409   *      be stat'ed, TCL_ERROR otherwise.  If TCL_ERROR is returned, an   *      be stat'ed, TCL_ERROR otherwise.  If TCL_ERROR is returned, an
1410   *      error message is left in interp's result.  If TCL_OK is returned,   *      error message is left in interp's result.  If TCL_OK is returned,
1411   *      *statPtr is filled with information about the specified file.   *      *statPtr is filled with information about the specified file.
1412   *   *
1413   * Side effects:   * Side effects:
1414   *      None.   *      None.
1415   *   *
1416   *---------------------------------------------------------------------------   *---------------------------------------------------------------------------
1417   */   */
1418    
1419  static int  static int
1420  GetStatBuf(interp, objPtr, statProc, statPtr)  GetStatBuf(interp, objPtr, statProc, statPtr)
1421      Tcl_Interp *interp;         /* Interp for error return.  May be NULL. */      Tcl_Interp *interp;         /* Interp for error return.  May be NULL. */
1422      Tcl_Obj *objPtr;            /* Path name to examine. */      Tcl_Obj *objPtr;            /* Path name to examine. */
1423      StatProc *statProc;         /* Either stat() or lstat() depending on      StatProc *statProc;         /* Either stat() or lstat() depending on
1424                                   * desired behavior. */                                   * desired behavior. */
1425      struct stat *statPtr;       /* Filled with info about file obtained by      struct stat *statPtr;       /* Filled with info about file obtained by
1426                                   * calling (*statProc)(). */                                   * calling (*statProc)(). */
1427  {  {
1428      char *fileName;      char *fileName;
1429      Tcl_DString ds;      Tcl_DString ds;
1430      int status;      int status;
1431            
1432      fileName = Tcl_GetString(objPtr);      fileName = Tcl_GetString(objPtr);
1433      fileName = Tcl_TranslateFileName(interp, fileName, &ds);      fileName = Tcl_TranslateFileName(interp, fileName, &ds);
1434      if (fileName == NULL) {      if (fileName == NULL) {
1435          return TCL_ERROR;          return TCL_ERROR;
1436      }      }
1437    
1438      status = (*statProc)(Tcl_DStringValue(&ds), statPtr);      status = (*statProc)(Tcl_DStringValue(&ds), statPtr);
1439      Tcl_DStringFree(&ds);      Tcl_DStringFree(&ds);
1440            
1441      if (status < 0) {      if (status < 0) {
1442          if (interp != NULL) {          if (interp != NULL) {
1443              Tcl_AppendResult(interp, "could not read \"",              Tcl_AppendResult(interp, "could not read \"",
1444                      Tcl_GetString(objPtr), "\": ",                      Tcl_GetString(objPtr), "\": ",
1445                      Tcl_PosixError(interp), (char *) NULL);                      Tcl_PosixError(interp), (char *) NULL);
1446          }          }
1447          return TCL_ERROR;          return TCL_ERROR;
1448      }      }
1449      return TCL_OK;      return TCL_OK;
1450  }  }
1451    
1452  /*  /*
1453   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1454   *   *
1455   * StoreStatData --   * StoreStatData --
1456   *   *
1457   *      This is a utility procedure that breaks out the fields of a   *      This is a utility procedure that breaks out the fields of a
1458   *      "stat" structure and stores them in textual form into the   *      "stat" structure and stores them in textual form into the
1459   *      elements of an associative array.   *      elements of an associative array.
1460   *   *
1461   * Results:   * Results:
1462   *      Returns a standard Tcl return value.  If an error occurs then   *      Returns a standard Tcl return value.  If an error occurs then
1463   *      a message is left in interp's result.   *      a message is left in interp's result.
1464   *   *
1465   * Side effects:   * Side effects:
1466   *      Elements of the associative array given by "varName" are modified.   *      Elements of the associative array given by "varName" are modified.
1467   *   *
1468   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1469   */   */
1470    
1471  static int  static int
1472  StoreStatData(interp, varName, statPtr)  StoreStatData(interp, varName, statPtr)
1473      Tcl_Interp *interp;                 /* Interpreter for error reports. */      Tcl_Interp *interp;                 /* Interpreter for error reports. */
1474      char *varName;                      /* Name of associative array variable      char *varName;                      /* Name of associative array variable
1475                                           * in which to store stat results. */                                           * in which to store stat results. */
1476      struct stat *statPtr;               /* Pointer to buffer containing      struct stat *statPtr;               /* Pointer to buffer containing
1477                                           * stat data to store in varName. */                                           * stat data to store in varName. */
1478  {  {
1479      char string[TCL_INTEGER_SPACE];      char string[TCL_INTEGER_SPACE];
1480    
1481      TclFormatInt(string, (long) statPtr->st_dev);      TclFormatInt(string, (long) statPtr->st_dev);
1482      if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)      if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)
1483              == NULL) {              == NULL) {
1484          return TCL_ERROR;          return TCL_ERROR;
1485      }      }
1486      TclFormatInt(string, (long) statPtr->st_ino);      TclFormatInt(string, (long) statPtr->st_ino);
1487      if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)      if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)
1488              == NULL) {              == NULL) {
1489          return TCL_ERROR;          return TCL_ERROR;
1490      }      }
1491      TclFormatInt(string, (unsigned short) statPtr->st_mode);      TclFormatInt(string, (unsigned short) statPtr->st_mode);
1492      if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)      if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)
1493              == NULL) {              == NULL) {
1494          return TCL_ERROR;          return TCL_ERROR;
1495      }      }
1496      TclFormatInt(string, (long) statPtr->st_nlink);      TclFormatInt(string, (long) statPtr->st_nlink);
1497      if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG)      if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG)
1498              == NULL) {              == NULL) {
1499          return TCL_ERROR;          return TCL_ERROR;
1500      }      }
1501      TclFormatInt(string, (long) statPtr->st_uid);      TclFormatInt(string, (long) statPtr->st_uid);
1502      if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG)      if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG)
1503              == NULL) {              == NULL) {
1504          return TCL_ERROR;          return TCL_ERROR;
1505      }      }
1506      TclFormatInt(string, (long) statPtr->st_gid);      TclFormatInt(string, (long) statPtr->st_gid);
1507      if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG)      if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG)
1508              == NULL) {              == NULL) {
1509          return TCL_ERROR;          return TCL_ERROR;
1510      }      }
1511      sprintf(string, "%lu", (unsigned long) statPtr->st_size);      sprintf(string, "%lu", (unsigned long) statPtr->st_size);
1512      if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG)      if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG)
1513              == NULL) {              == NULL) {
1514          return TCL_ERROR;          return TCL_ERROR;
1515      }      }
1516      TclFormatInt(string, (long) statPtr->st_atime);      TclFormatInt(string, (long) statPtr->st_atime);
1517      if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)      if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
1518              == NULL) {              == NULL) {
1519          return TCL_ERROR;          return TCL_ERROR;
1520      }      }
1521      TclFormatInt(string, (long) statPtr->st_mtime);      TclFormatInt(string, (long) statPtr->st_mtime);
1522      if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)      if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
1523              == NULL) {              == NULL) {
1524          return TCL_ERROR;          return TCL_ERROR;
1525      }      }
1526      TclFormatInt(string, (long) statPtr->st_ctime);      TclFormatInt(string, (long) statPtr->st_ctime);
1527      if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)      if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)
1528              == NULL) {              == NULL) {
1529          return TCL_ERROR;          return TCL_ERROR;
1530      }      }
1531      if (Tcl_SetVar2(interp, varName, "type",      if (Tcl_SetVar2(interp, varName, "type",
1532              GetTypeFromMode((unsigned short) statPtr->st_mode),              GetTypeFromMode((unsigned short) statPtr->st_mode),
1533              TCL_LEAVE_ERR_MSG) == NULL) {              TCL_LEAVE_ERR_MSG) == NULL) {
1534          return TCL_ERROR;          return TCL_ERROR;
1535      }      }
1536      return TCL_OK;      return TCL_OK;
1537  }  }
1538    
1539  /*  /*
1540   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1541   *   *
1542   * GetTypeFromMode --   * GetTypeFromMode --
1543   *   *
1544   *      Given a mode word, returns a string identifying the type of a   *      Given a mode word, returns a string identifying the type of a
1545   *      file.   *      file.
1546   *   *
1547   * Results:   * Results:
1548   *      A static text string giving the file type from mode.   *      A static text string giving the file type from mode.
1549   *   *
1550   * Side effects:   * Side effects:
1551   *      None.   *      None.
1552   *   *
1553   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1554   */   */
1555    
1556  static char *  static char *
1557  GetTypeFromMode(mode)  GetTypeFromMode(mode)
1558      int mode;      int mode;
1559  {  {
1560      if (S_ISREG(mode)) {      if (S_ISREG(mode)) {
1561          return "file";          return "file";
1562      } else if (S_ISDIR(mode)) {      } else if (S_ISDIR(mode)) {
1563          return "directory";          return "directory";
1564      } else if (S_ISCHR(mode)) {      } else if (S_ISCHR(mode)) {
1565          return "characterSpecial";          return "characterSpecial";
1566      } else if (S_ISBLK(mode)) {      } else if (S_ISBLK(mode)) {
1567          return "blockSpecial";          return "blockSpecial";
1568      } else if (S_ISFIFO(mode)) {      } else if (S_ISFIFO(mode)) {
1569          return "fifo";          return "fifo";
1570  #ifdef S_ISLNK  #ifdef S_ISLNK
1571      } else if (S_ISLNK(mode)) {      } else if (S_ISLNK(mode)) {
1572          return "link";          return "link";
1573  #endif  #endif
1574  #ifdef S_ISSOCK  #ifdef S_ISSOCK
1575      } else if (S_ISSOCK(mode)) {      } else if (S_ISSOCK(mode)) {
1576          return "socket";          return "socket";
1577  #endif  #endif
1578      }      }
1579      return "unknown";      return "unknown";
1580  }  }
1581    
1582  /*  /*
1583   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1584   *   *
1585   * Tcl_ForObjCmd --   * Tcl_ForObjCmd --
1586   *   *
1587   *      This procedure is invoked to process the "for" Tcl command.   *      This procedure is invoked to process the "for" Tcl command.
1588   *      See the user documentation for details on what it does.   *      See the user documentation for details on what it does.
1589   *   *
1590   *      With the bytecode compiler, this procedure is only called when   *      With the bytecode compiler, this procedure is only called when
1591   *      a command name is computed at runtime, and is "for" or the name   *      a command name is computed at runtime, and is "for" or the name
1592   *      to which "for" was renamed: e.g.,   *      to which "for" was renamed: e.g.,
1593   *      "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"   *      "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"
1594   *   *
1595   * Results:   * Results:
1596   *      A standard Tcl result.   *      A standard Tcl result.
1597   *   *
1598   * Side effects:   * Side effects:
1599   *      See the user documentation.   *      See the user documentation.
1600   *   *
1601   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1602   */   */
1603    
1604          /* ARGSUSED */          /* ARGSUSED */
1605  int  int
1606  Tcl_ForObjCmd(dummy, interp, objc, objv)  Tcl_ForObjCmd(dummy, interp, objc, objv)
1607      ClientData dummy;                   /* Not used. */      ClientData dummy;                   /* Not used. */
1608      Tcl_Interp *interp;                 /* Current interpreter. */      Tcl_Interp *interp;                 /* Current interpreter. */
1609      int objc;                           /* Number of arguments. */      int objc;                           /* Number of arguments. */
1610      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
1611  {  {
1612      int result, value;      int result, value;
1613    
1614      if (objc != 5) {      if (objc != 5) {
1615          Tcl_WrongNumArgs(interp, 1, objv, "start test next command");          Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
1616          return TCL_ERROR;          return TCL_ERROR;
1617      }      }
1618    
1619      result = Tcl_EvalObjEx(interp, objv[1], 0);      result = Tcl_EvalObjEx(interp, objv[1], 0);
1620      if (result != TCL_OK) {      if (result != TCL_OK) {
1621          if (result == TCL_ERROR) {          if (result == TCL_ERROR) {
1622              Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");              Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
1623          }          }
1624          return result;          return result;
1625      }      }
1626      while (1) {      while (1) {
1627          /*          /*
1628           * We need to reset the result before passing it off to           * We need to reset the result before passing it off to
1629           * Tcl_ExprBooleanObj.  Otherwise, any error message will be appended           * Tcl_ExprBooleanObj.  Otherwise, any error message will be appended
1630           * to the result of the last evaluation.           * to the result of the last evaluation.
1631           */           */
1632    
1633          Tcl_ResetResult(interp);          Tcl_ResetResult(interp);
1634          result = Tcl_ExprBooleanObj(interp, objv[2], &value);          result = Tcl_ExprBooleanObj(interp, objv[2], &value);
1635          if (result != TCL_OK) {          if (result != TCL_OK) {
1636              return result;              return result;
1637          }          }
1638          if (!value) {          if (!value) {
1639              break;              break;
1640          }          }
1641          result = Tcl_EvalObjEx(interp, objv[4], 0);          result = Tcl_EvalObjEx(interp, objv[4], 0);
1642          if ((result != TCL_OK) && (result != TCL_CONTINUE)) {          if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
1643              if (result == TCL_ERROR) {              if (result == TCL_ERROR) {
1644                  char msg[32 + TCL_INTEGER_SPACE];                  char msg[32 + TCL_INTEGER_SPACE];
1645    
1646                  sprintf(msg, "\n    (\"for\" body line %d)",interp->errorLine);                  sprintf(msg, "\n    (\"for\" body line %d)",interp->errorLine);
1647                  Tcl_AddErrorInfo(interp, msg);                  Tcl_AddErrorInfo(interp, msg);
1648              }              }
1649              break;              break;
1650          }          }
1651          result = Tcl_EvalObjEx(interp, objv[3], 0);          result = Tcl_EvalObjEx(interp, objv[3], 0);
1652          if (result == TCL_BREAK) {          if (result == TCL_BREAK) {
1653              break;              break;
1654          } else if (result != TCL_OK) {          } else if (result != TCL_OK) {
1655              if (result == TCL_ERROR) {              if (result == TCL_ERROR) {
1656                  Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");                  Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
1657              }              }
1658              return result;              return result;
1659          }          }
1660      }      }
1661      if (result == TCL_BREAK) {      if (result == TCL_BREAK) {
1662          result = TCL_OK;          result = TCL_OK;
1663      }      }
1664      if (result == TCL_OK) {      if (result == TCL_OK) {
1665          Tcl_ResetResult(interp);          Tcl_ResetResult(interp);
1666      }      }
1667      return result;      return result;
1668  }  }
1669    
1670  /*  /*
1671   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1672   *   *
1673   * Tcl_ForeachObjCmd --   * Tcl_ForeachObjCmd --
1674   *   *
1675   *      This object-based procedure is invoked to process the "foreach" Tcl   *      This object-based procedure is invoked to process the "foreach" Tcl
1676   *      command.  See the user documentation for details on what it does.   *      command.  See the user documentation for details on what it does.
1677   *   *
1678   * Results:   * Results:
1679   *      A standard Tcl object result.   *      A standard Tcl object result.
1680   *   *
1681   * Side effects:   * Side effects:
1682   *      See the user documentation.   *      See the user documentation.
1683   *   *
1684   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1685   */   */
1686    
1687          /* ARGSUSED */          /* ARGSUSED */
1688  int  int
1689  Tcl_ForeachObjCmd(dummy, interp, objc, objv)  Tcl_ForeachObjCmd(dummy, interp, objc, objv)
1690      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
1691      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
1692      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
1693      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
1694  {  {
1695      int result = TCL_OK;      int result = TCL_OK;
1696      int i;                      /* i selects a value list */      int i;                      /* i selects a value list */
1697      int j, maxj;                /* Number of loop iterations */      int j, maxj;                /* Number of loop iterations */
1698      int v;                      /* v selects a loop variable */      int v;                      /* v selects a loop variable */
1699      int numLists;               /* Count of value lists */      int numLists;               /* Count of value lists */
1700      Tcl_Obj *bodyPtr;      Tcl_Obj *bodyPtr;
1701    
1702      /*      /*
1703       * We copy the argument object pointers into a local array to avoid       * We copy the argument object pointers into a local array to avoid
1704       * the problem that "objv" might become invalid. It is a pointer into       * the problem that "objv" might become invalid. It is a pointer into
1705       * the evaluation stack and that stack might be grown and reallocated       * the evaluation stack and that stack might be grown and reallocated
1706       * if the loop body requires a large amount of stack space.       * if the loop body requires a large amount of stack space.
1707       */       */
1708            
1709  #define NUM_ARGS 9  #define NUM_ARGS 9
1710      Tcl_Obj *(argObjStorage[NUM_ARGS]);      Tcl_Obj *(argObjStorage[NUM_ARGS]);
1711      Tcl_Obj **argObjv = argObjStorage;      Tcl_Obj **argObjv = argObjStorage;
1712            
1713  #define STATIC_LIST_SIZE 4  #define STATIC_LIST_SIZE 4
1714      int indexArray[STATIC_LIST_SIZE];     /* Array of value list indices */      int indexArray[STATIC_LIST_SIZE];     /* Array of value list indices */
1715      int varcListArray[STATIC_LIST_SIZE];  /* # loop variables per list */      int varcListArray[STATIC_LIST_SIZE];  /* # loop variables per list */
1716      Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */      Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */
1717      int argcListArray[STATIC_LIST_SIZE];  /* Array of value list sizes */      int argcListArray[STATIC_LIST_SIZE];  /* Array of value list sizes */
1718      Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */      Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */
1719    
1720      int *index = indexArray;      int *index = indexArray;
1721      int *varcList = varcListArray;      int *varcList = varcListArray;
1722      Tcl_Obj ***varvList = varvListArray;      Tcl_Obj ***varvList = varvListArray;
1723      int *argcList = argcListArray;      int *argcList = argcListArray;
1724      Tcl_Obj ***argvList = argvListArray;      Tcl_Obj ***argvList = argvListArray;
1725    
1726      if (objc < 4 || (objc%2 != 0)) {      if (objc < 4 || (objc%2 != 0)) {
1727          Tcl_WrongNumArgs(interp, 1, objv,          Tcl_WrongNumArgs(interp, 1, objv,
1728                  "varList list ?varList list ...? command");                  "varList list ?varList list ...? command");
1729          return TCL_ERROR;          return TCL_ERROR;
1730      }      }
1731    
1732      /*      /*
1733       * Create the object argument array "argObjv". Make sure argObjv is       * Create the object argument array "argObjv". Make sure argObjv is
1734       * large enough to hold the objc arguments.       * large enough to hold the objc arguments.
1735       */       */
1736    
1737      if (objc > NUM_ARGS) {      if (objc > NUM_ARGS) {
1738          argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));          argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));
1739      }      }
1740      for (i = 0;  i < objc;  i++) {      for (i = 0;  i < objc;  i++) {
1741          argObjv[i] = objv[i];          argObjv[i] = objv[i];
1742      }      }
1743    
1744      /*      /*
1745       * Manage numList parallel value lists.       * Manage numList parallel value lists.
1746       * argvList[i] is a value list counted by argcList[i]       * argvList[i] is a value list counted by argcList[i]
1747       * varvList[i] is the list of variables associated with the value list       * varvList[i] is the list of variables associated with the value list
1748       * varcList[i] is the number of variables associated with the value list       * varcList[i] is the number of variables associated with the value list
1749       * index[i] is the current pointer into the value list argvList[i]       * index[i] is the current pointer into the value list argvList[i]
1750       */       */
1751    
1752      numLists = (objc-2)/2;      numLists = (objc-2)/2;
1753      if (numLists > STATIC_LIST_SIZE) {      if (numLists > STATIC_LIST_SIZE) {
1754          index = (int *) ckalloc(numLists * sizeof(int));          index = (int *) ckalloc(numLists * sizeof(int));
1755          varcList = (int *) ckalloc(numLists * sizeof(int));          varcList = (int *) ckalloc(numLists * sizeof(int));
1756          varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));          varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
1757          argcList = (int *) ckalloc(numLists * sizeof(int));          argcList = (int *) ckalloc(numLists * sizeof(int));
1758          argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));          argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
1759      }      }
1760      for (i = 0;  i < numLists;  i++) {      for (i = 0;  i < numLists;  i++) {
1761          index[i] = 0;          index[i] = 0;
1762          varcList[i] = 0;          varcList[i] = 0;
1763          varvList[i] = (Tcl_Obj **) NULL;          varvList[i] = (Tcl_Obj **) NULL;
1764          argcList[i] = 0;          argcList[i] = 0;
1765          argvList[i] = (Tcl_Obj **) NULL;          argvList[i] = (Tcl_Obj **) NULL;
1766      }      }
1767    
1768      /*      /*
1769       * Break up the value lists and variable lists into elements       * Break up the value lists and variable lists into elements
1770       */       */
1771    
1772      maxj = 0;      maxj = 0;
1773      for (i = 0;  i < numLists;  i++) {      for (i = 0;  i < numLists;  i++) {
1774          result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],          result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
1775                  &varcList[i], &varvList[i]);                  &varcList[i], &varvList[i]);
1776          if (result != TCL_OK) {          if (result != TCL_OK) {
1777              goto done;              goto done;
1778          }          }
1779          if (varcList[i] < 1) {          if (varcList[i] < 1) {
1780              Tcl_AppendToObj(Tcl_GetObjResult(interp),              Tcl_AppendToObj(Tcl_GetObjResult(interp),
1781                      "foreach varlist is empty", -1);                      "foreach varlist is empty", -1);
1782              result = TCL_ERROR;              result = TCL_ERROR;
1783              goto done;              goto done;
1784          }          }
1785                    
1786          result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],          result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
1787                  &argcList[i], &argvList[i]);                  &argcList[i], &argvList[i]);
1788          if (result != TCL_OK) {          if (result != TCL_OK) {
1789              goto done;              goto done;
1790          }          }
1791                    
1792          j = argcList[i] / varcList[i];          j = argcList[i] / varcList[i];
1793          if ((argcList[i] % varcList[i]) != 0) {          if ((argcList[i] % varcList[i]) != 0) {
1794              j++;              j++;
1795          }          }
1796          if (j > maxj) {          if (j > maxj) {
1797              maxj = j;              maxj = j;
1798          }          }
1799      }      }
1800    
1801      /*      /*
1802       * Iterate maxj times through the lists in parallel       * Iterate maxj times through the lists in parallel
1803       * If some value lists run out of values, set loop vars to ""       * If some value lists run out of values, set loop vars to ""
1804       */       */
1805            
1806      bodyPtr = argObjv[objc-1];      bodyPtr = argObjv[objc-1];
1807      for (j = 0;  j < maxj;  j++) {      for (j = 0;  j < maxj;  j++) {
1808          for (i = 0;  i < numLists;  i++) {          for (i = 0;  i < numLists;  i++) {
1809              /*              /*
1810               * If a variable or value list object has been converted to               * If a variable or value list object has been converted to
1811               * another kind of Tcl object, convert it back to a list object               * another kind of Tcl object, convert it back to a list object
1812               * and refetch the pointer to its element array.               * and refetch the pointer to its element array.
1813               */               */
1814    
1815              if (argObjv[1+i*2]->typePtr != &tclListType) {              if (argObjv[1+i*2]->typePtr != &tclListType) {
1816                  result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],                  result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
1817                          &varcList[i], &varvList[i]);                          &varcList[i], &varvList[i]);
1818                  if (result != TCL_OK) {                  if (result != TCL_OK) {
1819                      panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);                      panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
1820                  }                  }
1821              }              }
1822              if (argObjv[2+i*2]->typePtr != &tclListType) {              if (argObjv[2+i*2]->typePtr != &tclListType) {
1823                  result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],                  result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
1824                          &argcList[i], &argvList[i]);                          &argcList[i], &argvList[i]);
1825                  if (result != TCL_OK) {                  if (result != TCL_OK) {
1826                      panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);                      panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
1827                  }                  }
1828              }              }
1829                            
1830              for (v = 0;  v < varcList[i];  v++) {              for (v = 0;  v < varcList[i];  v++) {
1831                  int k = index[i]++;                  int k = index[i]++;
1832                  Tcl_Obj *valuePtr, *varValuePtr;                  Tcl_Obj *valuePtr, *varValuePtr;
1833                  int isEmptyObj = 0;                  int isEmptyObj = 0;
1834                                    
1835                  if (k < argcList[i]) {                  if (k < argcList[i]) {
1836                      valuePtr = argvList[i][k];                      valuePtr = argvList[i][k];
1837                  } else {                  } else {
1838                      valuePtr = Tcl_NewObj(); /* empty string */                      valuePtr = Tcl_NewObj(); /* empty string */
1839                      isEmptyObj = 1;                      isEmptyObj = 1;
1840                  }                  }
1841                  varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v],                  varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v],
1842                          NULL, valuePtr, 0);                          NULL, valuePtr, 0);
1843                  if (varValuePtr == NULL) {                  if (varValuePtr == NULL) {
1844                      if (isEmptyObj) {                      if (isEmptyObj) {
1845                          Tcl_DecrRefCount(valuePtr);                          Tcl_DecrRefCount(valuePtr);
1846                      }                      }
1847                      Tcl_ResetResult(interp);                      Tcl_ResetResult(interp);
1848                      Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),                      Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1849                          "couldn't set loop variable: \"",                          "couldn't set loop variable: \"",
1850                          Tcl_GetString(varvList[i][v]), "\"", (char *) NULL);                          Tcl_GetString(varvList[i][v]), "\"", (char *) NULL);
1851                      result = TCL_ERROR;                      result = TCL_ERROR;
1852                      goto done;                      goto done;
1853                  }                  }
1854    
1855              }              }
1856          }          }
1857    
1858          result = Tcl_EvalObjEx(interp, bodyPtr, 0);          result = Tcl_EvalObjEx(interp, bodyPtr, 0);
1859          if (result != TCL_OK) {          if (result != TCL_OK) {
1860              if (result == TCL_CONTINUE) {              if (result == TCL_CONTINUE) {
1861                  result = TCL_OK;                  result = TCL_OK;
1862              } else if (result == TCL_BREAK) {              } else if (result == TCL_BREAK) {
1863                  result = TCL_OK;                  result = TCL_OK;
1864                  break;                  break;
1865              } else if (result == TCL_ERROR) {              } else if (result == TCL_ERROR) {
1866                  char msg[32 + TCL_INTEGER_SPACE];                  char msg[32 + TCL_INTEGER_SPACE];
1867    
1868                  sprintf(msg, "\n    (\"foreach\" body line %d)",                  sprintf(msg, "\n    (\"foreach\" body line %d)",
1869                          interp->errorLine);                          interp->errorLine);
1870                  Tcl_AddObjErrorInfo(interp, msg, -1);                  Tcl_AddObjErrorInfo(interp, msg, -1);
1871                  break;                  break;
1872              } else {              } else {
1873                  break;                  break;
1874              }              }
1875          }          }
1876      }      }
1877      if (result == TCL_OK) {      if (result == TCL_OK) {
1878          Tcl_ResetResult(interp);          Tcl_ResetResult(interp);
1879      }      }
1880    
1881      done:      done:
1882      if (numLists > STATIC_LIST_SIZE) {      if (numLists > STATIC_LIST_SIZE) {
1883          ckfree((char *) index);          ckfree((char *) index);
1884          ckfree((char *) varcList);          ckfree((char *) varcList);
1885          ckfree((char *) argcList);          ckfree((char *) argcList);
1886          ckfree((char *) varvList);          ckfree((char *) varvList);
1887          ckfree((char *) argvList);          ckfree((char *) argvList);
1888      }      }
1889      if (argObjv != argObjStorage) {      if (argObjv != argObjStorage) {
1890          ckfree((char *) argObjv);          ckfree((char *) argObjv);
1891      }      }
1892      return result;      return result;
1893  #undef STATIC_LIST_SIZE  #undef STATIC_LIST_SIZE
1894  #undef NUM_ARGS  #undef NUM_ARGS
1895  }  }
1896    
1897  /*  /*
1898   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1899   *   *
1900   * Tcl_FormatObjCmd --   * Tcl_FormatObjCmd --
1901   *   *
1902   *      This procedure is invoked to process the "format" Tcl command.   *      This procedure is invoked to process the "format" Tcl command.
1903   *      See the user documentation for details on what it does.   *      See the user documentation for details on what it does.
1904   *   *
1905   * Results:   * Results:
1906   *      A standard Tcl result.   *      A standard Tcl result.
1907   *   *
1908   * Side effects:   * Side effects:
1909   *      See the user documentation.   *      See the user documentation.
1910   *   *
1911   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1912   */   */
1913    
1914          /* ARGSUSED */          /* ARGSUSED */
1915  int  int
1916  Tcl_FormatObjCmd(dummy, interp, objc, objv)  Tcl_FormatObjCmd(dummy, interp, objc, objv)
1917      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
1918      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
1919      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
1920      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
1921  {  {
1922      char *format;               /* Used to read characters from the format      char *format;               /* Used to read characters from the format
1923                                   * string. */                                   * string. */
1924      int formatLen;              /* The length of the format string */      int formatLen;              /* The length of the format string */
1925      char *endPtr;               /* Points to the last char in format array */      char *endPtr;               /* Points to the last char in format array */
1926      char newFormat[40];         /* A new format specifier is generated here. */      char newFormat[40];         /* A new format specifier is generated here. */
1927      int width;                  /* Field width from field specifier, or 0 if      int width;                  /* Field width from field specifier, or 0 if
1928                                   * no width given. */                                   * no width given. */
1929      int precision;              /* Field precision from field specifier, or 0      int precision;              /* Field precision from field specifier, or 0
1930                                   * if no precision given. */                                   * if no precision given. */
1931      int size;                   /* Number of bytes needed for result of      int size;                   /* Number of bytes needed for result of
1932                                   * conversion, based on type of conversion                                   * conversion, based on type of conversion
1933                                   * ("e", "s", etc.), width, and precision. */                                   * ("e", "s", etc.), width, and precision. */
1934      int intValue;               /* Used to hold value to pass to sprintf, if      int intValue;               /* Used to hold value to pass to sprintf, if
1935                                   * it's a one-word integer or char value */                                   * it's a one-word integer or char value */
1936      char *ptrValue = NULL;      /* Used to hold value to pass to sprintf, if      char *ptrValue = NULL;      /* Used to hold value to pass to sprintf, if
1937                                   * it's a one-word value. */                                   * it's a one-word value. */
1938      double doubleValue;         /* Used to hold value to pass to sprintf if      double doubleValue;         /* Used to hold value to pass to sprintf if
1939                                   * it's a double value. */                                   * it's a double value. */
1940      int whichValue;             /* Indicates which of intValue, ptrValue,      int whichValue;             /* Indicates which of intValue, ptrValue,
1941                                   * or doubleValue has the value to pass to                                   * or doubleValue has the value to pass to
1942                                   * sprintf, according to the following                                   * sprintf, according to the following
1943                                   * definitions: */                                   * definitions: */
1944  #   define INT_VALUE 0  #   define INT_VALUE 0
1945  #   define CHAR_VALUE 1  #   define CHAR_VALUE 1
1946  #   define PTR_VALUE 2  #   define PTR_VALUE 2
1947  #   define DOUBLE_VALUE 3  #   define DOUBLE_VALUE 3
1948  #   define STRING_VALUE 4  #   define STRING_VALUE 4
1949  #   define MAX_FLOAT_SIZE 320  #   define MAX_FLOAT_SIZE 320
1950            
1951      Tcl_Obj *resultPtr;         /* Where result is stored finally. */      Tcl_Obj *resultPtr;         /* Where result is stored finally. */
1952      char staticBuf[MAX_FLOAT_SIZE + 1];      char staticBuf[MAX_FLOAT_SIZE + 1];
1953                                  /* A static buffer to copy the format results                                  /* A static buffer to copy the format results
1954                                   * into */                                   * into */
1955      char *dst = staticBuf;      /* The buffer that sprintf writes into each      char *dst = staticBuf;      /* The buffer that sprintf writes into each
1956                                   * time the format processes a specifier */                                   * time the format processes a specifier */
1957      int dstSize = MAX_FLOAT_SIZE;      int dstSize = MAX_FLOAT_SIZE;
1958                                  /* The size of the dst buffer */                                  /* The size of the dst buffer */
1959      int noPercent;              /* Special case for speed:  indicates there's      int noPercent;              /* Special case for speed:  indicates there's
1960                                   * no field specifier, just a string to copy.*/                                   * no field specifier, just a string to copy.*/
1961      int objIndex;               /* Index of argument to substitute next. */      int objIndex;               /* Index of argument to substitute next. */
1962      int gotXpg = 0;             /* Non-zero means that an XPG3 %n$-style      int gotXpg = 0;             /* Non-zero means that an XPG3 %n$-style
1963                                   * specifier has been seen. */                                   * specifier has been seen. */
1964      int gotSequential = 0;      /* Non-zero means that a regular sequential      int gotSequential = 0;      /* Non-zero means that a regular sequential
1965                                   * (non-XPG3) conversion specifier has been                                   * (non-XPG3) conversion specifier has been
1966                                   * seen. */                                   * seen. */
1967      int useShort;               /* Value to be printed is short (half word). */      int useShort;               /* Value to be printed is short (half word). */
1968      char *end;                  /* Used to locate end of numerical fields. */      char *end;                  /* Used to locate end of numerical fields. */
1969      int stringLen = 0;          /* Length of string in characters rather      int stringLen = 0;          /* Length of string in characters rather
1970                                   * than bytes.  Used for %s substitution. */                                   * than bytes.  Used for %s substitution. */
1971      int gotMinus;               /* Non-zero indicates that a minus flag has      int gotMinus;               /* Non-zero indicates that a minus flag has
1972                                   * been seen in the current field. */                                   * been seen in the current field. */
1973      int gotPrecision;           /* Non-zero indicates that a precision has      int gotPrecision;           /* Non-zero indicates that a precision has
1974                                   * been set for the current field. */                                   * been set for the current field. */
1975      int gotZero;                /* Non-zero indicates that a zero flag has      int gotZero;                /* Non-zero indicates that a zero flag has
1976                                   * been seen in the current field. */                                   * been seen in the current field. */
1977    
1978      /*      /*
1979       * This procedure is a bit nasty.  The goal is to use sprintf to       * This procedure is a bit nasty.  The goal is to use sprintf to
1980       * do most of the dirty work.  There are several problems:       * do most of the dirty work.  There are several problems:
1981       * 1. this procedure can't trust its arguments.       * 1. this procedure can't trust its arguments.
1982       * 2. we must be able to provide a large enough result area to hold       * 2. we must be able to provide a large enough result area to hold
1983       *    whatever's generated.  This is hard to estimate.       *    whatever's generated.  This is hard to estimate.
1984       * 3. there's no way to move the arguments from objv to the call       * 3. there's no way to move the arguments from objv to the call
1985       *    to sprintf in a reasonable way.  This is particularly nasty       *    to sprintf in a reasonable way.  This is particularly nasty
1986       *    because some of the arguments may be two-word values (doubles).       *    because some of the arguments may be two-word values (doubles).
1987       * So, what happens here is to scan the format string one % group       * So, what happens here is to scan the format string one % group
1988       * at a time, making many individual calls to sprintf.       * at a time, making many individual calls to sprintf.
1989       */       */
1990    
1991      if (objc < 2) {      if (objc < 2) {
1992          Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");          Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
1993          return TCL_ERROR;          return TCL_ERROR;
1994      }      }
1995    
1996      format = (char *) Tcl_GetStringFromObj(objv[1], &formatLen);      format = (char *) Tcl_GetStringFromObj(objv[1], &formatLen);
1997      endPtr = format + formatLen;      endPtr = format + formatLen;
1998      resultPtr = Tcl_NewObj();      resultPtr = Tcl_NewObj();
1999      objIndex = 2;      objIndex = 2;
2000    
2001      while (format < endPtr) {      while (format < endPtr) {
2002          register char *newPtr = newFormat;          register char *newPtr = newFormat;
2003    
2004          width = precision = noPercent = useShort = 0;          width = precision = noPercent = useShort = 0;
2005          gotZero = gotMinus = gotPrecision = 0;          gotZero = gotMinus = gotPrecision = 0;
2006          whichValue = PTR_VALUE;          whichValue = PTR_VALUE;
2007    
2008          /*          /*
2009           * Get rid of any characters before the next field specifier.           * Get rid of any characters before the next field specifier.
2010           */           */
2011          if (*format != '%') {          if (*format != '%') {
2012              ptrValue = format;              ptrValue = format;
2013              while ((*format != '%') && (format < endPtr)) {              while ((*format != '%') && (format < endPtr)) {
2014                  format++;                  format++;
2015              }              }
2016              size = format - ptrValue;              size = format - ptrValue;
2017              noPercent = 1;              noPercent = 1;
2018              goto doField;              goto doField;
2019          }          }
2020    
2021          if (format[1] == '%') {          if (format[1] == '%') {
2022              ptrValue = format;              ptrValue = format;
2023              size = 1;              size = 1;
2024              noPercent = 1;              noPercent = 1;
2025              format += 2;              format += 2;
2026              goto doField;              goto doField;
2027          }          }
2028    
2029          /*          /*
2030           * Parse off a field specifier, compute how many characters           * Parse off a field specifier, compute how many characters
2031           * will be needed to store the result, and substitute for           * will be needed to store the result, and substitute for
2032           * "*" size specifiers.           * "*" size specifiers.
2033           */           */
2034          *newPtr = '%';          *newPtr = '%';
2035          newPtr++;          newPtr++;
2036          format++;          format++;
2037          if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */          if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
2038              int tmp;              int tmp;
2039    
2040              /*              /*
2041               * Check for an XPG3-style %n$ specification.  Note: there               * Check for an XPG3-style %n$ specification.  Note: there
2042               * must not be a mixture of XPG3 specs and non-XPG3 specs               * must not be a mixture of XPG3 specs and non-XPG3 specs
2043               * in the same format string.               * in the same format string.
2044               */               */
2045    
2046              tmp = strtoul(format, &end, 10);    /* INTL: "C" locale. */              tmp = strtoul(format, &end, 10);    /* INTL: "C" locale. */
2047              if (*end != '$') {              if (*end != '$') {
2048                  goto notXpg;                  goto notXpg;
2049              }              }
2050              format = end+1;              format = end+1;
2051              gotXpg = 1;              gotXpg = 1;
2052              if (gotSequential) {              if (gotSequential) {
2053                  goto mixedXPG;                  goto mixedXPG;
2054              }              }
2055              objIndex = tmp+1;              objIndex = tmp+1;
2056              if ((objIndex < 2) || (objIndex >= objc)) {              if ((objIndex < 2) || (objIndex >= objc)) {
2057                  goto badIndex;                  goto badIndex;
2058              }              }
2059              goto xpgCheckDone;              goto xpgCheckDone;
2060          }          }
2061    
2062          notXpg:          notXpg:
2063          gotSequential = 1;          gotSequential = 1;
2064          if (gotXpg) {          if (gotXpg) {
2065              goto mixedXPG;              goto mixedXPG;
2066          }          }
2067    
2068          xpgCheckDone:          xpgCheckDone:
2069          while ((*format == '-') || (*format == '#') || (*format == '0')          while ((*format == '-') || (*format == '#') || (*format == '0')
2070                  || (*format == ' ') || (*format == '+')) {                  || (*format == ' ') || (*format == '+')) {
2071              if (*format == '-') {              if (*format == '-') {
2072                  gotMinus = 1;                  gotMinus = 1;
2073              }              }
2074              if (*format == '0') {              if (*format == '0') {
2075                  /*                  /*
2076                   * This will be handled by sprintf for numbers, but we                   * This will be handled by sprintf for numbers, but we
2077                   * need to do the char/string ones ourselves                   * need to do the char/string ones ourselves
2078                   */                   */
2079                  gotZero = 1;                  gotZero = 1;
2080              }              }
2081              *newPtr = *format;              *newPtr = *format;
2082              newPtr++;              newPtr++;
2083              format++;              format++;
2084          }          }
2085          if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */          if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
2086              width = strtoul(format, &end, 10);  /* INTL: Tcl source. */              width = strtoul(format, &end, 10);  /* INTL: Tcl source. */
2087              format = end;              format = end;
2088          } else if (*format == '*') {          } else if (*format == '*') {
2089              if (objIndex >= objc) {              if (objIndex >= objc) {
2090                  goto badIndex;                  goto badIndex;
2091              }              }
2092              if (Tcl_GetIntFromObj(interp,       /* INTL: Tcl source. */              if (Tcl_GetIntFromObj(interp,       /* INTL: Tcl source. */
2093                      objv[objIndex], &width) != TCL_OK) {                      objv[objIndex], &width) != TCL_OK) {
2094                  goto fmtError;                  goto fmtError;
2095              }              }
2096              if (width < 0) {              if (width < 0) {
2097                  width = -width;                  width = -width;
2098                  *newPtr = '-';                  *newPtr = '-';
2099                  gotMinus = 1;                  gotMinus = 1;
2100                  newPtr++;                  newPtr++;
2101              }              }
2102              objIndex++;              objIndex++;
2103              format++;              format++;
2104          }          }
2105          if (width > 100000) {          if (width > 100000) {
2106              /*              /*
2107               * Don't allow arbitrarily large widths:  could cause core               * Don't allow arbitrarily large widths:  could cause core
2108               * dump when we try to allocate a zillion bytes of memory               * dump when we try to allocate a zillion bytes of memory
2109               * below.               * below.
2110               */               */
2111    
2112              width = 100000;              width = 100000;
2113          } else if (width < 0) {          } else if (width < 0) {
2114              width = 0;              width = 0;
2115          }          }
2116          if (width != 0) {          if (width != 0) {
2117              TclFormatInt(newPtr, width);        /* INTL: printf format. */              TclFormatInt(newPtr, width);        /* INTL: printf format. */
2118              while (*newPtr != 0) {              while (*newPtr != 0) {
2119                  newPtr++;                  newPtr++;
2120              }              }
2121          }          }
2122          if (*format == '.') {          if (*format == '.') {
2123              *newPtr = '.';              *newPtr = '.';
2124              newPtr++;              newPtr++;
2125              format++;              format++;
2126              gotPrecision = 1;              gotPrecision = 1;
2127          }          }
2128          if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */          if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
2129              precision = strtoul(format, &end, 10);  /* INTL: "C" locale. */              precision = strtoul(format, &end, 10);  /* INTL: "C" locale. */
2130              format = end;              format = end;
2131          } else if (*format == '*') {          } else if (*format == '*') {
2132              if (objIndex >= objc) {              if (objIndex >= objc) {
2133                  goto badIndex;                  goto badIndex;
2134              }              }
2135              if (Tcl_GetIntFromObj(interp,       /* INTL: Tcl source. */              if (Tcl_GetIntFromObj(interp,       /* INTL: Tcl source. */
2136                      objv[objIndex], &precision) != TCL_OK) {                      objv[objIndex], &precision) != TCL_OK) {
2137                  goto fmtError;                  goto fmtError;
2138              }              }
2139              objIndex++;              objIndex++;
2140              format++;              format++;
2141          }          }
2142          if (gotPrecision) {          if (gotPrecision) {
2143              TclFormatInt(newPtr, precision);    /* INTL: printf format. */              TclFormatInt(newPtr, precision);    /* INTL: printf format. */
2144              while (*newPtr != 0) {              while (*newPtr != 0) {
2145                  newPtr++;                  newPtr++;
2146              }              }
2147          }          }
2148          if (*format == 'l') {          if (*format == 'l') {
2149              format++;              format++;
2150          } else if (*format == 'h') {          } else if (*format == 'h') {
2151              useShort = 1;              useShort = 1;
2152              *newPtr = 'h';              *newPtr = 'h';
2153              newPtr++;              newPtr++;
2154              format++;              format++;
2155          }          }
2156          *newPtr = *format;          *newPtr = *format;
2157          newPtr++;          newPtr++;
2158          *newPtr = 0;          *newPtr = 0;
2159          if (objIndex >= objc) {          if (objIndex >= objc) {
2160              goto badIndex;              goto badIndex;
2161          }          }
2162          switch (*format) {          switch (*format) {
2163              case 'i':              case 'i':
2164                  newPtr[-1] = 'd';                  newPtr[-1] = 'd';
2165              case 'd':              case 'd':
2166              case 'o':              case 'o':
2167              case 'u':              case 'u':
2168              case 'x':              case 'x':
2169              case 'X':              case 'X':
2170                  if (Tcl_GetIntFromObj(interp,   /* INTL: Tcl source. */                  if (Tcl_GetIntFromObj(interp,   /* INTL: Tcl source. */
2171                          objv[objIndex], &intValue) != TCL_OK) {                          objv[objIndex], &intValue) != TCL_OK) {
2172                      goto fmtError;                      goto fmtError;
2173                  }                  }
2174                  whichValue = INT_VALUE;                  whichValue = INT_VALUE;
2175                  size = 40 + precision;                  size = 40 + precision;
2176                  break;                  break;
2177              case 's':              case 's':
2178                  /*                  /*
2179                   * Compute the length of the string in characters and add                   * Compute the length of the string in characters and add
2180                   * any additional space required by the field width.  All of                   * any additional space required by the field width.  All of
2181                   * the extra characters will be spaces, so one byte per                   * the extra characters will be spaces, so one byte per
2182                   * character is adequate.                   * character is adequate.
2183                   */                   */
2184    
2185                  whichValue = STRING_VALUE;                  whichValue = STRING_VALUE;
2186                  ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);                  ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
2187                  stringLen = Tcl_NumUtfChars(ptrValue, size);                  stringLen = Tcl_NumUtfChars(ptrValue, size);
2188                  if (gotPrecision && (precision < stringLen)) {                  if (gotPrecision && (precision < stringLen)) {
2189                      stringLen = precision;                      stringLen = precision;
2190                  }                  }
2191                  size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;                  size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
2192                  if (width > stringLen) {                  if (width > stringLen) {
2193                      size += (width - stringLen);                      size += (width - stringLen);
2194                  }                  }
2195                  break;                  break;
2196              case 'c':              case 'c':
2197                  if (Tcl_GetIntFromObj(interp,   /* INTL: Tcl source. */                  if (Tcl_GetIntFromObj(interp,   /* INTL: Tcl source. */
2198                          objv[objIndex], &intValue) != TCL_OK) {                          objv[objIndex], &intValue) != TCL_OK) {
2199                      goto fmtError;                      goto fmtError;
2200                  }                  }
2201                  whichValue = CHAR_VALUE;                  whichValue = CHAR_VALUE;
2202                  size = width + TCL_UTF_MAX;                  size = width + TCL_UTF_MAX;
2203                  break;                  break;
2204              case 'e':              case 'e':
2205              case 'E':              case 'E':
2206              case 'f':              case 'f':
2207              case 'g':              case 'g':
2208              case 'G':              case 'G':
2209                  if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */                  if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */
2210                          objv[objIndex], &doubleValue) != TCL_OK) {                          objv[objIndex], &doubleValue) != TCL_OK) {
2211                      goto fmtError;                      goto fmtError;
2212                  }                  }
2213                  whichValue = DOUBLE_VALUE;                  whichValue = DOUBLE_VALUE;
2214                  size = MAX_FLOAT_SIZE;                  size = MAX_FLOAT_SIZE;
2215                  if (precision > 10) {                  if (precision > 10) {
2216                      size += precision;                      size += precision;
2217                  }                  }
2218                  break;                  break;
2219              case 0:              case 0:
2220                  Tcl_SetResult(interp,                  Tcl_SetResult(interp,
2221                          "format string ended in middle of field specifier",                          "format string ended in middle of field specifier",
2222                          TCL_STATIC);                          TCL_STATIC);
2223                  goto fmtError;                  goto fmtError;
2224              default: {              default: {
2225                  char buf[40];                  char buf[40];
2226                  sprintf(buf, "bad field specifier \"%c\"", *format);                  sprintf(buf, "bad field specifier \"%c\"", *format);
2227                  Tcl_SetResult(interp, buf, TCL_VOLATILE);                  Tcl_SetResult(interp, buf, TCL_VOLATILE);
2228                  goto fmtError;                  goto fmtError;
2229              }              }
2230          }          }
2231          objIndex++;          objIndex++;
2232          format++;          format++;
2233    
2234          /*          /*
2235           * Make sure that there's enough space to hold the formatted           * Make sure that there's enough space to hold the formatted
2236           * result, then format it.           * result, then format it.
2237           */           */
2238    
2239          doField:          doField:
2240          if (width > size) {          if (width > size) {
2241              size = width;              size = width;
2242          }          }
2243          if (noPercent) {          if (noPercent) {
2244              Tcl_AppendToObj(resultPtr, ptrValue, size);              Tcl_AppendToObj(resultPtr, ptrValue, size);
2245          } else {          } else {
2246              if (size > dstSize) {              if (size > dstSize) {
2247                  if (dst != staticBuf) {                  if (dst != staticBuf) {
2248                      ckfree(dst);                      ckfree(dst);
2249                  }                  }
2250                  dst = (char *) ckalloc((unsigned) (size + 1));                  dst = (char *) ckalloc((unsigned) (size + 1));
2251                  dstSize = size;                  dstSize = size;
2252              }              }
2253              switch (whichValue) {              switch (whichValue) {
2254                  case DOUBLE_VALUE: {                  case DOUBLE_VALUE: {
2255                      sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */                      sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */
2256                      break;                      break;
2257                  }                  }
2258                  case INT_VALUE: {                  case INT_VALUE: {
2259                      if (useShort) {                      if (useShort) {
2260                          sprintf(dst, newFormat, (short) intValue);                          sprintf(dst, newFormat, (short) intValue);
2261                      } else {                      } else {
2262                          sprintf(dst, newFormat, intValue);                          sprintf(dst, newFormat, intValue);
2263                      }                      }
2264                      break;                      break;
2265                  }                  }
2266                  case CHAR_VALUE: {                  case CHAR_VALUE: {
2267                      char *ptr;                      char *ptr;
2268                      char padChar = (gotZero ? '0' : ' ');                      char padChar = (gotZero ? '0' : ' ');
2269                      ptr = dst;                      ptr = dst;
2270                      if (!gotMinus) {                      if (!gotMinus) {
2271                          for ( ; --width > 0; ptr++) {                          for ( ; --width > 0; ptr++) {
2272                              *ptr = padChar;                              *ptr = padChar;
2273                          }                          }
2274                      }                      }
2275                      ptr += Tcl_UniCharToUtf(intValue, ptr);                      ptr += Tcl_UniCharToUtf(intValue, ptr);
2276                      for ( ; --width > 0; ptr++) {                      for ( ; --width > 0; ptr++) {
2277                          *ptr = padChar;                          *ptr = padChar;
2278                      }                      }
2279                      *ptr = '\0';                      *ptr = '\0';
2280                      break;                      break;
2281                  }                  }
2282                  case STRING_VALUE: {                  case STRING_VALUE: {
2283                      char *ptr;                      char *ptr;
2284                      char padChar = (gotZero ? '0' : ' ');                      char padChar = (gotZero ? '0' : ' ');
2285                      int pad;                      int pad;
2286    
2287                      ptr = dst;                      ptr = dst;
2288                      if (width > stringLen) {                      if (width > stringLen) {
2289                          pad = width - stringLen;                          pad = width - stringLen;
2290                      } else {                      } else {
2291                          pad = 0;                          pad = 0;
2292                      }                      }
2293    
2294                      if (!gotMinus) {                      if (!gotMinus) {
2295                          while (pad > 0) {                          while (pad > 0) {
2296                              *ptr++ = padChar;                              *ptr++ = padChar;
2297                              pad--;                              pad--;
2298                          }                          }
2299                      }                      }
2300    
2301                      size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;                      size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
2302                      if (size) {                      if (size) {
2303                          memcpy(ptr, ptrValue, (size_t) size);                          memcpy(ptr, ptrValue, (size_t) size);
2304                          ptr += size;                          ptr += size;
2305                      }                      }
2306                      while (pad > 0) {                      while (pad > 0) {
2307                          *ptr++ = padChar;                          *ptr++ = padChar;
2308                          pad--;                          pad--;
2309                      }                      }
2310                      *ptr = '\0';                      *ptr = '\0';
2311                      break;                      break;
2312                  }                  }
2313                  default: {                  default: {
2314                      sprintf(dst, newFormat, ptrValue);                      sprintf(dst, newFormat, ptrValue);
2315                      break;                      break;
2316                  }                  }
2317              }              }
2318              Tcl_AppendToObj(resultPtr, dst, -1);              Tcl_AppendToObj(resultPtr, dst, -1);
2319          }          }
2320      }      }
2321    
2322      Tcl_SetObjResult(interp, resultPtr);      Tcl_SetObjResult(interp, resultPtr);
2323      if(dst != staticBuf) {      if(dst != staticBuf) {
2324          ckfree(dst);          ckfree(dst);
2325      }      }
2326      return TCL_OK;      return TCL_OK;
2327    
2328      mixedXPG:      mixedXPG:
2329      Tcl_SetResult(interp,      Tcl_SetResult(interp,
2330              "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);              "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
2331      goto fmtError;      goto fmtError;
2332    
2333      badIndex:      badIndex:
2334      if (gotXpg) {      if (gotXpg) {
2335          Tcl_SetResult(interp,          Tcl_SetResult(interp,
2336                  "\"%n$\" argument index out of range", TCL_STATIC);                  "\"%n$\" argument index out of range", TCL_STATIC);
2337      } else {      } else {
2338          Tcl_SetResult(interp,          Tcl_SetResult(interp,
2339                  "not enough arguments for all format specifiers", TCL_STATIC);                  "not enough arguments for all format specifiers", TCL_STATIC);
2340      }      }
2341    
2342      fmtError:      fmtError:
2343      if(dst != staticBuf) {      if(dst != staticBuf) {
2344          ckfree(dst);          ckfree(dst);
2345      }      }
2346      Tcl_DecrRefCount(resultPtr);      Tcl_DecrRefCount(resultPtr);
2347      return TCL_ERROR;      return TCL_ERROR;
2348  }  }
2349    
2350  /*  /*
2351   *---------------------------------------------------------------------------   *---------------------------------------------------------------------------
2352   *   *
2353   * StringifyObjects --   * StringifyObjects --
2354   *   *
2355   *      Helper function to bridge the gap between an object-based procedure   *      Helper function to bridge the gap between an object-based procedure
2356   *      and an older string-based procedure.   *      and an older string-based procedure.
2357   *   *
2358   *      Given an array of objects, allocate an array that consists of the   *      Given an array of objects, allocate an array that consists of the
2359   *      string representations of those objects.   *      string representations of those objects.
2360   *   *
2361   * Results:   * Results:
2362   *      The return value is a pointer to the newly allocated array of   *      The return value is a pointer to the newly allocated array of
2363   *      strings.  Elements 0 to (objc-1) of the string array point to the   *      strings.  Elements 0 to (objc-1) of the string array point to the
2364   *      string representation of the corresponding element in the source   *      string representation of the corresponding element in the source
2365   *      object array; element objc of the string array is NULL.   *      object array; element objc of the string array is NULL.
2366   *   *
2367   * Side effects:   * Side effects:
2368   *      Memory allocated.  The caller must eventually free this memory   *      Memory allocated.  The caller must eventually free this memory
2369   *      by calling ckfree() on the return value.   *      by calling ckfree() on the return value.
2370   *   *
2371   *---------------------------------------------------------------------------   *---------------------------------------------------------------------------
2372   */   */
2373    
2374  static char **  static char **
2375  StringifyObjects(objc, objv)  StringifyObjects(objc, objv)
2376      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
2377      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
2378  {  {
2379      int i;      int i;
2380      char **argv;      char **argv;
2381            
2382      argv = (char **) ckalloc((objc + 1) * sizeof(char *));      argv = (char **) ckalloc((objc + 1) * sizeof(char *));
2383      for (i = 0; i < objc; i++) {      for (i = 0; i < objc; i++) {
2384          argv[i] = Tcl_GetString(objv[i]);          argv[i] = Tcl_GetString(objv[i]);
2385      }      }
2386      argv[i] = NULL;      argv[i] = NULL;
2387      return argv;      return argv;
2388  }  }
2389    
2390  /* End of tclcmdah.c */  /* End of tclcmdah.c */

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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25