/[dtapublic]/sf_code/esrgpcpj/shared/tcl_base/tclcmdah.c
ViewVC logotype

Annotation of /sf_code/esrgpcpj/shared/tcl_base/tclcmdah.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25