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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25