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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 66 - (show 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 /* $Header$ */
2 /*
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 /* End of tclcmdah.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25