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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25