1 /*
2 * tclCmdAH.c --
3 *
4 * This file contains the top-level command routines for most of the Tcl
5 * built-in commands whose names begin with the letters A to H.
6 *
7 * Copyright (c) 1987-1993 The Regents of the University of California.
8 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
9 *
10 * See the file "license.terms" for information on usage and redistribution of
11 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 */
13
14 #include "tclInt.h"
15 #include <locale.h>
16
17 /*
18 * Prototypes for local procedures defined in this file:
19 */
20
21 static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr,
22 int mode);
23 static int EncodingDirsObjCmd(ClientData dummy,
24 Tcl_Interp *interp, int objc,
25 Tcl_Obj *const objv[]);
26 static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr,
27 Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr);
28 static const char * GetTypeFromMode(int mode);
29 static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName,
30 Tcl_StatBuf *statPtr);
31
32 /*
33 *----------------------------------------------------------------------
34 *
35 * Tcl_BreakObjCmd --
36 *
37 * This procedure is invoked to process the "break" Tcl command. See the
38 * user documentation for details on what it does.
39 *
40 * With the bytecode compiler, this procedure is only called when a
41 * command name is computed at runtime, and is "break" or the name to
42 * which "break" was renamed: e.g., "set z break; $z"
43 *
44 * Results:
45 * A standard Tcl result.
46 *
47 * Side effects:
48 * See the user documentation.
49 *
50 *----------------------------------------------------------------------
51 */
52
53 /* ARGSUSED */
54 int
Tcl_BreakObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])55 Tcl_BreakObjCmd(
56 ClientData dummy, /* Not used. */
57 Tcl_Interp *interp, /* Current interpreter. */
58 int objc, /* Number of arguments. */
59 Tcl_Obj *const objv[]) /* Argument objects. */
60 {
61 if (objc != 1) {
62 Tcl_WrongNumArgs(interp, 1, objv, NULL);
63 return TCL_ERROR;
64 }
65 return TCL_BREAK;
66 }
67
68 /*
69 *----------------------------------------------------------------------
70 *
71 * Tcl_CaseObjCmd --
72 *
73 * This procedure is invoked to process the "case" Tcl command. See the
74 * user documentation for details on what it does. THIS COMMAND IS
75 * OBSOLETE AND DEPRECATED. SLATED FOR REMOVAL IN TCL 9.0.
76 *
77 * Results:
78 * A standard Tcl object result.
79 *
80 * Side effects:
81 * See the user documentation.
82 *
83 *----------------------------------------------------------------------
84 */
85
86 /* ARGSUSED */
87 int
Tcl_CaseObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])88 Tcl_CaseObjCmd(
89 ClientData dummy, /* Not used. */
90 Tcl_Interp *interp, /* Current interpreter. */
91 int objc, /* Number of arguments. */
92 Tcl_Obj *const objv[]) /* Argument objects. */
93 {
94 register int i;
95 int body, result, caseObjc;
96 char *stringPtr, *arg;
97 Tcl_Obj *const *caseObjv;
98 Tcl_Obj *armPtr;
99
100 if (objc < 3) {
101 Tcl_WrongNumArgs(interp, 1, objv,
102 "string ?in? patList body ... ?default body?");
103 return TCL_ERROR;
104 }
105
106 stringPtr = TclGetString(objv[1]);
107 body = -1;
108
109 arg = TclGetString(objv[2]);
110 if (strcmp(arg, "in") == 0) {
111 i = 3;
112 } else {
113 i = 2;
114 }
115 caseObjc = objc - i;
116 caseObjv = objv + i;
117
118 /*
119 * If all of the pattern/command pairs are lumped into a single argument,
120 * split them out again.
121 */
122
123 if (caseObjc == 1) {
124 Tcl_Obj **newObjv;
125
126 TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
127 caseObjv = newObjv;
128 }
129
130 for (i = 0; i < caseObjc; i += 2) {
131 int patObjc, j;
132 const char **patObjv;
133 char *pat, *p;
134
135 if (i == (caseObjc - 1)) {
136 Tcl_ResetResult(interp);
137 Tcl_AppendResult(interp, "extra case pattern with no body", NULL);
138 return TCL_ERROR;
139 }
140
141 /*
142 * Check for special case of single pattern (no list) with no
143 * backslash sequences.
144 */
145
146 pat = TclGetString(caseObjv[i]);
147 for (p = pat; *p != '\0'; p++) {
148 if (TclIsSpaceProc(*p) || (*p == '\\')) {
149 break;
150 }
151 }
152 if (*p == '\0') {
153 if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
154 body = i + 1;
155 }
156 if (Tcl_StringMatch(stringPtr, pat)) {
157 body = i + 1;
158 goto match;
159 }
160 continue;
161 }
162
163 /*
164 * Break up pattern lists, then check each of the patterns in the
165 * list.
166 */
167
168 result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
169 if (result != TCL_OK) {
170 return result;
171 }
172 for (j = 0; j < patObjc; j++) {
173 if (Tcl_StringMatch(stringPtr, patObjv[j])) {
174 body = i + 1;
175 break;
176 }
177 }
178 ckfree((char *) patObjv);
179 if (j < patObjc) {
180 break;
181 }
182 }
183
184 match:
185 if (body != -1) {
186 armPtr = caseObjv[body - 1];
187 result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
188 if (result == TCL_ERROR) {
189 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
190 "\n (\"%.50s\" arm line %d)",
191 TclGetString(armPtr), interp->errorLine));
192 }
193 return result;
194 }
195
196 /*
197 * Nothing matched: return nothing.
198 */
199
200 return TCL_OK;
201 }
202
203 /*
204 *----------------------------------------------------------------------
205 *
206 * Tcl_CatchObjCmd --
207 *
208 * This object-based procedure is invoked to process the "catch" Tcl
209 * command. See the user documentation for details on what it does.
210 *
211 * Results:
212 * A standard Tcl object result.
213 *
214 * Side effects:
215 * See the user documentation.
216 *
217 *----------------------------------------------------------------------
218 */
219
220 /* ARGSUSED */
221 int
Tcl_CatchObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])222 Tcl_CatchObjCmd(
223 ClientData dummy, /* Not used. */
224 Tcl_Interp *interp, /* Current interpreter. */
225 int objc, /* Number of arguments. */
226 Tcl_Obj *const objv[]) /* Argument objects. */
227 {
228 Tcl_Obj *varNamePtr = NULL;
229 Tcl_Obj *optionVarNamePtr = NULL;
230 int result;
231 Interp *iPtr = (Interp *) interp;
232
233 if ((objc < 2) || (objc > 4)) {
234 Tcl_WrongNumArgs(interp, 1, objv,
235 "script ?resultVarName? ?optionVarName?");
236 return TCL_ERROR;
237 }
238
239 if (objc >= 3) {
240 varNamePtr = objv[2];
241 }
242 if (objc == 4) {
243 optionVarNamePtr = objv[3];
244 }
245
246 /*
247 * TIP #280. Make invoking context available to caught script.
248 */
249
250 result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
251
252 /*
253 * We disable catch in interpreters where the limit has been exceeded.
254 */
255
256 if (Tcl_LimitExceeded(interp)) {
257 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
258 "\n (\"catch\" body line %d)", interp->errorLine));
259 return TCL_ERROR;
260 }
261
262 if (objc >= 3) {
263 if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
264 Tcl_GetObjResult(interp), 0)) {
265 Tcl_ResetResult(interp);
266 Tcl_AppendResult(interp,
267 "couldn't save command result in variable", NULL);
268 return TCL_ERROR;
269 }
270 }
271 if (objc == 4) {
272 Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
273 if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL,
274 options, 0)) {
275 Tcl_ResetResult(interp);
276 Tcl_AppendResult(interp,
277 "couldn't save return options in variable", NULL);
278 return TCL_ERROR;
279 }
280 }
281
282 Tcl_ResetResult(interp);
283 Tcl_SetObjResult(interp, Tcl_NewIntObj(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. See the
293 * 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
Tcl_CdObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])306 Tcl_CdObjCmd(
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 Tcl_Obj *dir;
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 dir = objv[1];
322 } else {
323 TclNewLiteralStringObj(dir, "~");
324 Tcl_IncrRefCount(dir);
325 }
326 if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) {
327 result = TCL_ERROR;
328 } else {
329 result = Tcl_FSChdir(dir);
330 if (result != TCL_OK) {
331 Tcl_AppendResult(interp, "couldn't change working directory to \"",
332 TclGetString(dir), "\": ", Tcl_PosixError(interp), NULL);
333 result = TCL_ERROR;
334 }
335 }
336 if (objc != 2) {
337 Tcl_DecrRefCount(dir);
338 }
339 return result;
340 }
341
342 /*
343 *----------------------------------------------------------------------
344 *
345 * Tcl_ConcatObjCmd --
346 *
347 * This object-based procedure is invoked to process the "concat" Tcl
348 * command. See the user documentation for details on what it does.
349 *
350 * Results:
351 * A standard Tcl object result.
352 *
353 * Side effects:
354 * See the user documentation.
355 *
356 *----------------------------------------------------------------------
357 */
358
359 /* ARGSUSED */
360 int
Tcl_ConcatObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])361 Tcl_ConcatObjCmd(
362 ClientData dummy, /* Not used. */
363 Tcl_Interp *interp, /* Current interpreter. */
364 int objc, /* Number of arguments. */
365 Tcl_Obj *const objv[]) /* Argument objects. */
366 {
367 if (objc >= 2) {
368 Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
369 }
370 return TCL_OK;
371 }
372
373 /*
374 *----------------------------------------------------------------------
375 *
376 * Tcl_ContinueObjCmd --
377 *
378 * This procedure is invoked to process the "continue" Tcl command. See
379 * the user documentation for details on what it does.
380 *
381 * With the bytecode compiler, this procedure is only called when a
382 * command name is computed at runtime, and is "continue" or the name to
383 * which "continue" was renamed: e.g., "set z continue; $z"
384 *
385 * Results:
386 * A standard Tcl result.
387 *
388 * Side effects:
389 * See the user documentation.
390 *
391 *----------------------------------------------------------------------
392 */
393
394 /* ARGSUSED */
395 int
Tcl_ContinueObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])396 Tcl_ContinueObjCmd(
397 ClientData dummy, /* Not used. */
398 Tcl_Interp *interp, /* Current interpreter. */
399 int objc, /* Number of arguments. */
400 Tcl_Obj *const objv[]) /* Argument objects. */
401 {
402 if (objc != 1) {
403 Tcl_WrongNumArgs(interp, 1, objv, NULL);
404 return TCL_ERROR;
405 }
406 return TCL_CONTINUE;
407 }
408
409 /*
410 *----------------------------------------------------------------------
411 *
412 * Tcl_EncodingObjCmd --
413 *
414 * This command manipulates encodings.
415 *
416 * Results:
417 * A standard Tcl result.
418 *
419 * Side effects:
420 * See the user documentation.
421 *
422 *----------------------------------------------------------------------
423 */
424
425 int
Tcl_EncodingObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])426 Tcl_EncodingObjCmd(
427 ClientData dummy, /* Not used. */
428 Tcl_Interp *interp, /* Current interpreter. */
429 int objc, /* Number of arguments. */
430 Tcl_Obj *const objv[]) /* Argument objects. */
431 {
432 int index;
433
434 static const char *optionStrings[] = {
435 "convertfrom", "convertto", "dirs", "names", "system",
436 NULL
437 };
438 enum options {
439 ENC_CONVERTFROM, ENC_CONVERTTO, ENC_DIRS, ENC_NAMES, ENC_SYSTEM
440 };
441
442 if (objc < 2) {
443 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
444 return TCL_ERROR;
445 }
446 if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
447 &index) != TCL_OK) {
448 return TCL_ERROR;
449 }
450
451 switch ((enum options) index) {
452 case ENC_CONVERTTO:
453 case ENC_CONVERTFROM: {
454 Tcl_Obj *data;
455 Tcl_DString ds;
456 Tcl_Encoding encoding;
457 int length;
458 char *stringPtr;
459
460 if (objc == 3) {
461 encoding = Tcl_GetEncoding(interp, NULL);
462 data = objv[2];
463 } else if (objc == 4) {
464 if (Tcl_GetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) {
465 return TCL_ERROR;
466 }
467 data = objv[3];
468 } else {
469 Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
470 return TCL_ERROR;
471 }
472
473 if ((enum options) index == ENC_CONVERTFROM) {
474 /*
475 * Treat the string as binary data.
476 */
477
478 stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
479 Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds);
480
481 /*
482 * Note that we cannot use Tcl_DStringResult here because it will
483 * truncate the string at the first null byte.
484 */
485
486 Tcl_SetObjResult(interp, Tcl_NewStringObj(
487 Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
488 Tcl_DStringFree(&ds);
489 } else {
490 /*
491 * Store the result as binary data.
492 */
493
494 stringPtr = TclGetStringFromObj(data, &length);
495 Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds);
496 Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
497 (unsigned char *) Tcl_DStringValue(&ds),
498 Tcl_DStringLength(&ds)));
499 Tcl_DStringFree(&ds);
500 }
501
502 Tcl_FreeEncoding(encoding);
503 break;
504 }
505 case ENC_DIRS:
506 return EncodingDirsObjCmd(dummy, interp, objc, objv);
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 case ENC_SYSTEM:
515 if (objc > 3) {
516 Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
517 return TCL_ERROR;
518 }
519 if (objc == 2) {
520 Tcl_SetObjResult(interp, Tcl_NewStringObj(
521 Tcl_GetEncodingName(NULL), -1));
522 } else {
523 return Tcl_SetSystemEncoding(interp, TclGetString(objv[2]));
524 }
525 break;
526 }
527 return TCL_OK;
528 }
529
530 /*
531 *----------------------------------------------------------------------
532 *
533 * EncodingDirsObjCmd --
534 *
535 * This command manipulates the encoding search path.
536 *
537 * Results:
538 * A standard Tcl result.
539 *
540 * Side effects:
541 * Can set the encoding search path.
542 *
543 *----------------------------------------------------------------------
544 */
545
546 int
EncodingDirsObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])547 EncodingDirsObjCmd(
548 ClientData dummy, /* Not used. */
549 Tcl_Interp *interp, /* Current interpreter. */
550 int objc, /* Number of arguments. */
551 Tcl_Obj *const objv[]) /* Argument objects. */
552 {
553 Tcl_Obj *dirListObj;
554
555 if (objc > 3) {
556 Tcl_WrongNumArgs(interp, 2, objv, "?dirList?");
557 return TCL_ERROR;
558 }
559 if (objc == 2) {
560 Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath());
561 return TCL_OK;
562 }
563
564 dirListObj = objv[2];
565 if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) {
566 Tcl_AppendResult(interp, "expected directory list but got \"",
567 TclGetString(dirListObj), "\"", NULL);
568 return TCL_ERROR;
569 }
570 Tcl_SetObjResult(interp, dirListObj);
571 return TCL_OK;
572 }
573
574 /*
575 *----------------------------------------------------------------------
576 *
577 * Tcl_ErrorObjCmd --
578 *
579 * This procedure is invoked to process the "error" Tcl command. See the
580 * user documentation for details on what it does.
581 *
582 * Results:
583 * A standard Tcl object result.
584 *
585 * Side effects:
586 * See the user documentation.
587 *
588 *----------------------------------------------------------------------
589 */
590
591 /* ARGSUSED */
592 int
Tcl_ErrorObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])593 Tcl_ErrorObjCmd(
594 ClientData dummy, /* Not used. */
595 Tcl_Interp *interp, /* Current interpreter. */
596 int objc, /* Number of arguments. */
597 Tcl_Obj *const objv[]) /* Argument objects. */
598 {
599 Tcl_Obj *options, *optName;
600
601 if ((objc < 2) || (objc > 4)) {
602 Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
603 return TCL_ERROR;
604 }
605
606 TclNewLiteralStringObj(options, "-code error -level 0");
607
608 if (objc >= 3) { /* Process the optional info argument */
609 TclNewLiteralStringObj(optName, "-errorinfo");
610 Tcl_ListObjAppendElement(NULL, options, optName);
611 Tcl_ListObjAppendElement(NULL, options, objv[2]);
612 }
613
614 if (objc >= 4) { /* Process the optional code argument */
615 TclNewLiteralStringObj(optName, "-errorcode");
616 Tcl_ListObjAppendElement(NULL, options, optName);
617 Tcl_ListObjAppendElement(NULL, options, objv[3]);
618 }
619
620 Tcl_SetObjResult(interp, objv[1]);
621 return Tcl_SetReturnOptions(interp, options);
622 }
623
624 /*
625 *----------------------------------------------------------------------
626 *
627 * Tcl_EvalObjCmd --
628 *
629 * This object-based procedure is invoked to process the "eval" Tcl
630 * command. See the user documentation for details on what it does.
631 *
632 * Results:
633 * A standard Tcl object result.
634 *
635 * Side effects:
636 * See the user documentation.
637 *
638 *----------------------------------------------------------------------
639 */
640
641 /* ARGSUSED */
642 int
Tcl_EvalObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])643 Tcl_EvalObjCmd(
644 ClientData dummy, /* Not used. */
645 Tcl_Interp *interp, /* Current interpreter. */
646 int objc, /* Number of arguments. */
647 Tcl_Obj *const objv[]) /* Argument objects. */
648 {
649 int result;
650 register Tcl_Obj *objPtr;
651 Interp *iPtr = (Interp *) interp;
652
653 if (objc < 2) {
654 Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
655 return TCL_ERROR;
656 }
657
658 if (objc == 2) {
659 /*
660 * TIP #280. Make argument location available to eval'd script.
661 */
662
663 CmdFrame* invoker = iPtr->cmdFramePtr;
664 int word = 1;
665 TclArgumentGet (interp, objv[1], &invoker, &word);
666
667 result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
668 invoker, word);
669 } else {
670 /*
671 * More than one argument: concatenate them together with spaces
672 * between, then evaluate the result. Tcl_EvalObjEx will delete the
673 * object when it decrements its refcount after eval'ing it.
674 */
675
676 objPtr = Tcl_ConcatObj(objc-1, objv+1);
677
678 /*
679 * TIP #280. Make invoking context available to eval'd script.
680 */
681
682 result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
683 }
684 if (result == TCL_ERROR) {
685 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
686 "\n (\"eval\" body line %d)", interp->errorLine));
687 }
688 return result;
689 }
690
691 /*
692 *----------------------------------------------------------------------
693 *
694 * Tcl_ExitObjCmd --
695 *
696 * This procedure is invoked to process the "exit" Tcl command. See the
697 * user documentation for details on what it does.
698 *
699 * Results:
700 * A standard Tcl object result.
701 *
702 * Side effects:
703 * See the user documentation.
704 *
705 *----------------------------------------------------------------------
706 */
707
708 /* ARGSUSED */
709 int
Tcl_ExitObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])710 Tcl_ExitObjCmd(
711 ClientData dummy, /* Not used. */
712 Tcl_Interp *interp, /* Current interpreter. */
713 int objc, /* Number of arguments. */
714 Tcl_Obj *const objv[]) /* Argument objects. */
715 {
716 int value;
717
718 if ((objc != 1) && (objc != 2)) {
719 Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
720 return TCL_ERROR;
721 }
722
723 if (objc == 1) {
724 value = 0;
725 } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
726 return TCL_ERROR;
727 }
728 Tcl_Exit(value);
729 /*NOTREACHED*/
730 return TCL_OK; /* Better not ever reach this! */
731 }
732
733 /*
734 *----------------------------------------------------------------------
735 *
736 * Tcl_ExprObjCmd --
737 *
738 * This object-based procedure is invoked to process the "expr" Tcl
739 * command. See the user documentation for details on what it does.
740 *
741 * With the bytecode compiler, this procedure is called in two
742 * circumstances: 1) to execute expr commands that are too complicated or
743 * too unsafe to try compiling directly into an inline sequence of
744 * instructions, and 2) to execute commands where the command name is
745 * computed at runtime and is "expr" or the name to which "expr" was
746 * renamed (e.g., "set z expr; $z 2+3")
747 *
748 * Results:
749 * A standard Tcl object result.
750 *
751 * Side effects:
752 * See the user documentation.
753 *
754 *----------------------------------------------------------------------
755 */
756
757 /* ARGSUSED */
758 int
Tcl_ExprObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])759 Tcl_ExprObjCmd(
760 ClientData dummy, /* Not used. */
761 Tcl_Interp *interp, /* Current interpreter. */
762 int objc, /* Number of arguments. */
763 Tcl_Obj *const objv[]) /* Argument objects. */
764 {
765 Tcl_Obj *resultPtr;
766 int result;
767
768 if (objc < 2) {
769 Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
770 return TCL_ERROR;
771 }
772
773 if (objc == 2) {
774 result = Tcl_ExprObj(interp, objv[1], &resultPtr);
775 } else {
776 Tcl_Obj *objPtr = Tcl_ConcatObj(objc-1, objv+1);
777 Tcl_IncrRefCount(objPtr);
778 result = Tcl_ExprObj(interp, objPtr, &resultPtr);
779 Tcl_DecrRefCount(objPtr);
780 }
781
782 if (result == TCL_OK) {
783 Tcl_SetObjResult(interp, resultPtr);
784 Tcl_DecrRefCount(resultPtr); /* Done with the result object */
785 }
786
787 return result;
788 }
789
790 /*
791 *----------------------------------------------------------------------
792 *
793 * Tcl_FileObjCmd --
794 *
795 * This procedure is invoked to process the "file" Tcl command. See the
796 * user documentation for details on what it does. PLEASE NOTE THAT THIS
797 * FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the
798 * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any
799 * case this assertion should be tested.
800 *
801 * Results:
802 * A standard Tcl result.
803 *
804 * Side effects:
805 * See the user documentation.
806 *
807 *----------------------------------------------------------------------
808 */
809
810 /* ARGSUSED */
811 int
Tcl_FileObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])812 Tcl_FileObjCmd(
813 ClientData dummy, /* Not used. */
814 Tcl_Interp *interp, /* Current interpreter. */
815 int objc, /* Number of arguments. */
816 Tcl_Obj *const objv[]) /* Argument objects. */
817 {
818 int index, value;
819 Tcl_StatBuf buf;
820 struct utimbuf tval;
821
822 /*
823 * This list of constants should match the fileOption string array below.
824 */
825
826 static const char *fileOptions[] = {
827 "atime", "attributes", "channels", "copy",
828 "delete",
829 "dirname", "executable", "exists", "extension",
830 "isdirectory", "isfile", "join", "link",
831 "lstat", "mtime", "mkdir", "nativename",
832 "normalize", "owned",
833 "pathtype", "readable", "readlink", "rename",
834 "rootname", "separator", "size", "split",
835 "stat", "system",
836 "tail", "type", "volumes", "writable",
837 NULL
838 };
839 enum options {
840 FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY,
841 FCMD_DELETE,
842 FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION,
843 FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK,
844 FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME,
845 FCMD_NORMALIZE, FCMD_OWNED,
846 FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME,
847 FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT,
848 FCMD_STAT, FCMD_SYSTEM,
849 FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE
850 };
851
852 if (objc < 2) {
853 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
854 return TCL_ERROR;
855 }
856 if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
857 &index) != TCL_OK) {
858 return TCL_ERROR;
859 }
860
861 switch ((enum options) index) {
862
863 case FCMD_ATIME:
864 case FCMD_MTIME:
865 if ((objc < 3) || (objc > 4)) {
866 Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
867 return TCL_ERROR;
868 }
869 if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
870 return TCL_ERROR;
871 }
872 if (objc == 4) {
873 /*
874 * Need separate variable for reading longs from an object on
875 * 64-bit platforms. [Bug #698146]
876 */
877
878 long newTime;
879
880 if (TclGetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
881 return TCL_ERROR;
882 }
883
884 if (index == FCMD_ATIME) {
885 tval.actime = newTime;
886 tval.modtime = buf.st_mtime;
887 } else { /* index == FCMD_MTIME */
888 tval.actime = buf.st_atime;
889 tval.modtime = newTime;
890 }
891
892 if (Tcl_FSUtime(objv[2], &tval) != 0) {
893 Tcl_AppendResult(interp, "could not set ",
894 (index == FCMD_ATIME ? "access" : "modification"),
895 " time for file \"", TclGetString(objv[2]), "\": ",
896 Tcl_PosixError(interp), NULL);
897 return TCL_ERROR;
898 }
899
900 /*
901 * Do another stat to ensure that the we return the new recognized
902 * atime - hopefully the same as the one we sent in. However, fs's
903 * like FAT don't even know what atime is.
904 */
905
906 if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
907 return TCL_ERROR;
908 }
909 }
910
911 Tcl_SetObjResult(interp, Tcl_NewLongObj((long)
912 (index == FCMD_ATIME ? buf.st_atime : buf.st_mtime)));
913 return TCL_OK;
914 case FCMD_ATTRIBUTES:
915 return TclFileAttrsCmd(interp, objc, objv);
916 case FCMD_CHANNELS:
917 if ((objc < 2) || (objc > 3)) {
918 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
919 return TCL_ERROR;
920 }
921 return Tcl_GetChannelNamesEx(interp,
922 ((objc == 2) ? NULL : TclGetString(objv[2])));
923 case FCMD_COPY:
924 return TclFileCopyCmd(interp, objc, objv);
925 case FCMD_DELETE:
926 return TclFileDeleteCmd(interp, objc, objv);
927 case FCMD_DIRNAME: {
928 Tcl_Obj *dirPtr;
929
930 if (objc != 3) {
931 goto only3Args;
932 }
933 dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME);
934 if (dirPtr == NULL) {
935 return TCL_ERROR;
936 } else {
937 Tcl_SetObjResult(interp, dirPtr);
938 Tcl_DecrRefCount(dirPtr);
939 return TCL_OK;
940 }
941 }
942 case FCMD_EXECUTABLE:
943 if (objc != 3) {
944 goto only3Args;
945 }
946 return CheckAccess(interp, objv[2], X_OK);
947 case FCMD_EXISTS:
948 if (objc != 3) {
949 goto only3Args;
950 }
951 return CheckAccess(interp, objv[2], F_OK);
952 case FCMD_EXTENSION: {
953 Tcl_Obj *ext;
954
955 if (objc != 3) {
956 goto only3Args;
957 }
958 ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION);
959 if (ext != NULL) {
960 Tcl_SetObjResult(interp, ext);
961 Tcl_DecrRefCount(ext);
962 return TCL_OK;
963 } else {
964 return TCL_ERROR;
965 }
966 }
967 case FCMD_ISDIRECTORY:
968 if (objc != 3) {
969 goto only3Args;
970 }
971 value = 0;
972 if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
973 value = S_ISDIR(buf.st_mode);
974 }
975 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
976 return TCL_OK;
977 case FCMD_ISFILE:
978 if (objc != 3) {
979 goto only3Args;
980 }
981 value = 0;
982 if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
983 value = S_ISREG(buf.st_mode);
984 }
985 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
986 return TCL_OK;
987 case FCMD_OWNED:
988 if (objc != 3) {
989 goto only3Args;
990 }
991 value = 0;
992 if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
993 /*
994 * For Windows, there are no user ids associated with a file, so
995 * we always return 1.
996 */
997
998 #if defined(__WIN32__) || defined(__CYGWIN__)
999 value = 1;
1000 #else
1001 value = (geteuid() == buf.st_uid);
1002 #endif
1003 }
1004 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
1005 return TCL_OK;
1006 case FCMD_JOIN: {
1007 Tcl_Obj *resObj;
1008
1009 if (objc < 3) {
1010 Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
1011 return TCL_ERROR;
1012 }
1013 resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
1014 Tcl_SetObjResult(interp, resObj);
1015 return TCL_OK;
1016 }
1017 case FCMD_LINK: {
1018 Tcl_Obj *contents;
1019 int index;
1020
1021 if (objc < 3 || objc > 5) {
1022 Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?");
1023 return TCL_ERROR;
1024 }
1025
1026 /*
1027 * Index of the 'source' argument.
1028 */
1029
1030 if (objc == 5) {
1031 index = 3;
1032 } else {
1033 index = 2;
1034 }
1035
1036 if (objc > 3) {
1037 int linkAction;
1038 if (objc == 5) {
1039 /*
1040 * We have a '-linktype' argument.
1041 */
1042
1043 static const char *linkTypes[] = {
1044 "-symbolic", "-hard", NULL
1045 };
1046 if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch",
1047 0, &linkAction) != TCL_OK) {
1048 return TCL_ERROR;
1049 }
1050 if (linkAction == 0) {
1051 linkAction = TCL_CREATE_SYMBOLIC_LINK;
1052 } else {
1053 linkAction = TCL_CREATE_HARD_LINK;
1054 }
1055 } else {
1056 linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
1057 }
1058 if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
1059 return TCL_ERROR;
1060 }
1061
1062 /*
1063 * Create link from source to target.
1064 */
1065
1066 contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
1067 if (contents == NULL) {
1068 /*
1069 * We handle three common error cases specially, and for all
1070 * other errors, we use the standard posix error message.
1071 */
1072
1073 if (errno == EEXIST) {
1074 Tcl_AppendResult(interp, "could not create new link \"",
1075 TclGetString(objv[index]),
1076 "\": that path already exists", NULL);
1077 } else if (errno == ENOENT) {
1078 /*
1079 * There are two cases here: either the target doesn't
1080 * exist, or the directory of the src doesn't exist.
1081 */
1082
1083 int access;
1084 Tcl_Obj *dirPtr = TclPathPart(interp, objv[index],
1085 TCL_PATH_DIRNAME);
1086
1087 if (dirPtr == NULL) {
1088 return TCL_ERROR;
1089 }
1090 access = Tcl_FSAccess(dirPtr, F_OK);
1091 Tcl_DecrRefCount(dirPtr);
1092 if (access != 0) {
1093 Tcl_AppendResult(interp,
1094 "could not create new link \"",
1095 TclGetString(objv[index]),
1096 "\": no such file or directory", NULL);
1097 } else {
1098 Tcl_AppendResult(interp,
1099 "could not create new link \"",
1100 TclGetString(objv[index]), "\": target \"",
1101 TclGetString(objv[index+1]),
1102 "\" doesn't exist", NULL);
1103 }
1104 } else {
1105 Tcl_AppendResult(interp,
1106 "could not create new link \"",
1107 TclGetString(objv[index]), "\" pointing to \"",
1108 TclGetString(objv[index+1]), "\": ",
1109 Tcl_PosixError(interp), NULL);
1110 }
1111 return TCL_ERROR;
1112 }
1113 } else {
1114 if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
1115 return TCL_ERROR;
1116 }
1117
1118 /*
1119 * Read link
1120 */
1121
1122 contents = Tcl_FSLink(objv[index], NULL, 0);
1123 if (contents == NULL) {
1124 Tcl_AppendResult(interp, "could not read link \"",
1125 TclGetString(objv[index]), "\": ",
1126 Tcl_PosixError(interp), NULL);
1127 return TCL_ERROR;
1128 }
1129 }
1130 Tcl_SetObjResult(interp, contents);
1131 if (objc == 3) {
1132 /*
1133 * If we are reading a link, we need to free this result refCount.
1134 * If we are creating a link, this will just be objv[index+1], and
1135 * so we don't own it.
1136 */
1137
1138 Tcl_DecrRefCount(contents);
1139 }
1140 return TCL_OK;
1141 }
1142 case FCMD_LSTAT:
1143 if (objc != 4) {
1144 Tcl_WrongNumArgs(interp, 2, objv, "name varName");
1145 return TCL_ERROR;
1146 }
1147 if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
1148 return TCL_ERROR;
1149 }
1150 return StoreStatData(interp, objv[3], &buf);
1151 case FCMD_STAT:
1152 if (objc != 4) {
1153 Tcl_WrongNumArgs(interp, 2, objv, "name varName");
1154 return TCL_ERROR;
1155 }
1156 if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
1157 return TCL_ERROR;
1158 }
1159 return StoreStatData(interp, objv[3], &buf);
1160 case FCMD_SIZE:
1161 if (objc != 3) {
1162 goto only3Args;
1163 }
1164 if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
1165 return TCL_ERROR;
1166 }
1167 Tcl_SetObjResult(interp,
1168 Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size));
1169 return TCL_OK;
1170 case FCMD_TYPE:
1171 if (objc != 3) {
1172 goto only3Args;
1173 }
1174 if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
1175 return TCL_ERROR;
1176 }
1177 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1178 GetTypeFromMode((unsigned short) buf.st_mode), -1));
1179 return TCL_OK;
1180 case FCMD_MKDIR:
1181 if (objc < 3) {
1182 Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
1183 return TCL_ERROR;
1184 }
1185 return TclFileMakeDirsCmd(interp, objc, objv);
1186 case FCMD_NATIVENAME: {
1187 const char *fileName;
1188 Tcl_DString ds;
1189
1190 if (objc != 3) {
1191 goto only3Args;
1192 }
1193 fileName = TclGetString(objv[2]);
1194 fileName = Tcl_TranslateFileName(interp, fileName, &ds);
1195 if (fileName == NULL) {
1196 return TCL_ERROR;
1197 }
1198 Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName,
1199 Tcl_DStringLength(&ds)));
1200 Tcl_DStringFree(&ds);
1201 return TCL_OK;
1202 }
1203 case FCMD_NORMALIZE: {
1204 Tcl_Obj *fileName;
1205
1206 if (objc != 3) {
1207 Tcl_WrongNumArgs(interp, 2, objv, "filename");
1208 return TCL_ERROR;
1209 }
1210
1211 fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
1212 if (fileName == NULL) {
1213 return TCL_ERROR;
1214 }
1215 Tcl_SetObjResult(interp, fileName);
1216 return TCL_OK;
1217 }
1218 case FCMD_PATHTYPE: {
1219 Tcl_Obj *typeName;
1220
1221 if (objc != 3) {
1222 goto only3Args;
1223 }
1224
1225 switch (Tcl_FSGetPathType(objv[2])) {
1226 case TCL_PATH_ABSOLUTE:
1227 TclNewLiteralStringObj(typeName, "absolute");
1228 break;
1229 case TCL_PATH_RELATIVE:
1230 TclNewLiteralStringObj(typeName, "relative");
1231 break;
1232 case TCL_PATH_VOLUME_RELATIVE:
1233 TclNewLiteralStringObj(typeName, "volumerelative");
1234 break;
1235 default:
1236 return TCL_OK;
1237 }
1238 Tcl_SetObjResult(interp, typeName);
1239 return TCL_OK;
1240 }
1241 case FCMD_READABLE:
1242 if (objc != 3) {
1243 goto only3Args;
1244 }
1245 return CheckAccess(interp, objv[2], R_OK);
1246 case FCMD_READLINK: {
1247 Tcl_Obj *contents;
1248
1249 if (objc != 3) {
1250 goto only3Args;
1251 }
1252
1253 if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
1254 return TCL_ERROR;
1255 }
1256
1257 contents = Tcl_FSLink(objv[2], NULL, 0);
1258
1259 if (contents == NULL) {
1260 Tcl_AppendResult(interp, "could not readlink \"",
1261 TclGetString(objv[2]), "\": ", Tcl_PosixError(interp),
1262 NULL);
1263 return TCL_ERROR;
1264 }
1265 Tcl_SetObjResult(interp, contents);
1266 Tcl_DecrRefCount(contents);
1267 return TCL_OK;
1268 }
1269 case FCMD_RENAME:
1270 return TclFileRenameCmd(interp, objc, objv);
1271 case FCMD_ROOTNAME: {
1272 Tcl_Obj *root;
1273
1274 if (objc != 3) {
1275 goto only3Args;
1276 }
1277 root = TclPathPart(interp, objv[2], TCL_PATH_ROOT);
1278 if (root != NULL) {
1279 Tcl_SetObjResult(interp, root);
1280 Tcl_DecrRefCount(root);
1281 return TCL_OK;
1282 } else {
1283 return TCL_ERROR;
1284 }
1285 }
1286 case FCMD_SEPARATOR:
1287 if ((objc < 2) || (objc > 3)) {
1288 Tcl_WrongNumArgs(interp, 2, objv, "?name?");
1289 return TCL_ERROR;
1290 }
1291 if (objc == 2) {
1292 const char *separator = NULL; /* lint */
1293
1294 switch (tclPlatform) {
1295 case TCL_PLATFORM_UNIX:
1296 separator = "/";
1297 break;
1298 case TCL_PLATFORM_WINDOWS:
1299 separator = "\\";
1300 break;
1301 }
1302 Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1));
1303 } else {
1304 Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
1305
1306 if (separatorObj == NULL) {
1307 Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC);
1308 return TCL_ERROR;
1309 }
1310 Tcl_SetObjResult(interp, separatorObj);
1311 }
1312 return TCL_OK;
1313 case FCMD_SPLIT: {
1314 Tcl_Obj *res;
1315
1316 if (objc != 3) {
1317 goto only3Args;
1318 }
1319 res = Tcl_FSSplitPath(objv[2], NULL);
1320 if (res == NULL) {
1321 /* How can the interp be NULL here?! DKF */
1322 if (interp != NULL) {
1323 Tcl_AppendResult(interp, "could not read \"",
1324 TclGetString(objv[2]),
1325 "\": no such file or directory", NULL);
1326 }
1327 return TCL_ERROR;
1328 }
1329 Tcl_SetObjResult(interp, res);
1330 return TCL_OK;
1331 }
1332 case FCMD_SYSTEM: {
1333 Tcl_Obj *fsInfo;
1334
1335 if (objc != 3) {
1336 goto only3Args;
1337 }
1338 fsInfo = Tcl_FSFileSystemInfo(objv[2]);
1339 if (fsInfo == NULL) {
1340 Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC);
1341 return TCL_ERROR;
1342 }
1343 Tcl_SetObjResult(interp, fsInfo);
1344 return TCL_OK;
1345 }
1346 case FCMD_TAIL: {
1347 Tcl_Obj *dirPtr;
1348
1349 if (objc != 3) {
1350 goto only3Args;
1351 }
1352 dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL);
1353 if (dirPtr == NULL) {
1354 return TCL_ERROR;
1355 }
1356 Tcl_SetObjResult(interp, dirPtr);
1357 Tcl_DecrRefCount(dirPtr);
1358 return TCL_OK;
1359 }
1360 case FCMD_VOLUMES:
1361 if (objc != 2) {
1362 Tcl_WrongNumArgs(interp, 2, objv, NULL);
1363 return TCL_ERROR;
1364 }
1365 Tcl_SetObjResult(interp, Tcl_FSListVolumes());
1366 return TCL_OK;
1367 case FCMD_WRITABLE:
1368 if (objc != 3) {
1369 goto only3Args;
1370 }
1371 return CheckAccess(interp, objv[2], W_OK);
1372 }
1373
1374 only3Args:
1375 Tcl_WrongNumArgs(interp, 2, objv, "name");
1376 return TCL_ERROR;
1377 }
1378
1379 /*
1380 *---------------------------------------------------------------------------
1381 *
1382 * CheckAccess --
1383 *
1384 * Utility procedure used by Tcl_FileObjCmd() to query file attributes
1385 * available through the access() system call.
1386 *
1387 * Results:
1388 * Always returns TCL_OK. Sets interp's result to boolean true or false
1389 * depending on whether the file has the specified attribute.
1390 *
1391 * Side effects:
1392 * None.
1393 *
1394 *---------------------------------------------------------------------------
1395 */
1396
1397 static int
CheckAccess(Tcl_Interp * interp,Tcl_Obj * pathPtr,int mode)1398 CheckAccess(
1399 Tcl_Interp *interp, /* Interp for status return. Must not be
1400 * NULL. */
1401 Tcl_Obj *pathPtr, /* Name of file to check. */
1402 int mode) /* Attribute to check; passed as argument to
1403 * access(). */
1404 {
1405 int value;
1406
1407 if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
1408 value = 0;
1409 } else {
1410 value = (Tcl_FSAccess(pathPtr, mode) == 0);
1411 }
1412 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
1413
1414 return TCL_OK;
1415 }
1416
1417 /*
1418 *---------------------------------------------------------------------------
1419 *
1420 * GetStatBuf --
1421 *
1422 * Utility procedure used by Tcl_FileObjCmd() to query file attributes
1423 * available through the stat() or lstat() system call.
1424 *
1425 * Results:
1426 * The return value is TCL_OK if the specified file exists and can be
1427 * stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an error
1428 * message is left in interp's result. If TCL_OK is returned, *statPtr is
1429 * filled with information about the specified file.
1430 *
1431 * Side effects:
1432 * None.
1433 *
1434 *---------------------------------------------------------------------------
1435 */
1436
1437 static int
GetStatBuf(Tcl_Interp * interp,Tcl_Obj * pathPtr,Tcl_FSStatProc * statProc,Tcl_StatBuf * statPtr)1438 GetStatBuf(
1439 Tcl_Interp *interp, /* Interp for error return. May be NULL. */
1440 Tcl_Obj *pathPtr, /* Path name to examine. */
1441 Tcl_FSStatProc *statProc, /* Either stat() or lstat() depending on
1442 * desired behavior. */
1443 Tcl_StatBuf *statPtr) /* Filled with info about file obtained by
1444 * calling (*statProc)(). */
1445 {
1446 int status;
1447
1448 if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
1449 return TCL_ERROR;
1450 }
1451
1452 status = (*statProc)(pathPtr, statPtr);
1453
1454 if (status < 0) {
1455 if (interp != NULL) {
1456 Tcl_AppendResult(interp, "could not read \"",
1457 TclGetString(pathPtr), "\": ",
1458 Tcl_PosixError(interp), NULL);
1459 }
1460 return TCL_ERROR;
1461 }
1462 return TCL_OK;
1463 }
1464
1465 /*
1466 *----------------------------------------------------------------------
1467 *
1468 * StoreStatData --
1469 *
1470 * This is a utility procedure that breaks out the fields of a "stat"
1471 * structure and stores them in textual form into the elements of an
1472 * associative array.
1473 *
1474 * Results:
1475 * Returns a standard Tcl return value. If an error occurs then a message
1476 * is left in interp's result.
1477 *
1478 * Side effects:
1479 * Elements of the associative array given by "varName" are modified.
1480 *
1481 *----------------------------------------------------------------------
1482 */
1483
1484 static int
StoreStatData(Tcl_Interp * interp,Tcl_Obj * varName,Tcl_StatBuf * statPtr)1485 StoreStatData(
1486 Tcl_Interp *interp, /* Interpreter for error reports. */
1487 Tcl_Obj *varName, /* Name of associative array variable in which
1488 * to store stat results. */
1489 Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to
1490 * store in varName. */
1491 {
1492 Tcl_Obj *field, *value;
1493 register unsigned short mode;
1494
1495 /*
1496 * Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
1497 *
1498 * Might be a better idea to call Tcl_SetVar2Ex() instead, except we want
1499 * to have an object (i.e. possibly cached) array variable name but a
1500 * string element name, so no API exists. Messy.
1501 */
1502
1503 #define STORE_ARY(fieldName, object) \
1504 TclNewLiteralStringObj(field, fieldName); \
1505 Tcl_IncrRefCount(field); \
1506 value = (object); \
1507 if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \
1508 TclDecrRefCount(field); \
1509 return TCL_ERROR; \
1510 } \
1511 TclDecrRefCount(field);
1512
1513 /*
1514 * Watch out porters; the inode is meant to be an *unsigned* value, so the
1515 * cast might fail when there isn't a real arithmentic 'long long' type...
1516 */
1517
1518 STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev));
1519 STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
1520 STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink));
1521 STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid));
1522 STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid));
1523 STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
1524 #ifdef HAVE_STRUCT_STAT_ST_BLOCKS
1525 STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
1526 #endif
1527 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
1528 STORE_ARY("blksize", Tcl_NewLongObj((long)statPtr->st_blksize));
1529 #endif
1530 STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime));
1531 STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime));
1532 STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime));
1533 mode = (unsigned short) statPtr->st_mode;
1534 STORE_ARY("mode", Tcl_NewIntObj(mode));
1535 STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
1536 #undef STORE_ARY
1537
1538 return TCL_OK;
1539 }
1540
1541 /*
1542 *----------------------------------------------------------------------
1543 *
1544 * GetTypeFromMode --
1545 *
1546 * Given a mode word, returns a string identifying the type of a 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 const char *
GetTypeFromMode(int mode)1558 GetTypeFromMode(
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. See the
1589 * user documentation for details on what it does.
1590 *
1591 * With the bytecode compiler, this procedure is only called when a
1592 * command name is computed at runtime, and is "for" or the name to which
1593 * "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
Tcl_ForObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1607 Tcl_ForObjCmd(
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 Interp *iPtr = (Interp *) interp;
1615
1616 if (objc != 5) {
1617 Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
1618 return TCL_ERROR;
1619 }
1620
1621 /*
1622 * TIP #280. Make invoking context available to initial script.
1623 */
1624
1625 result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
1626 if (result != TCL_OK) {
1627 if (result == TCL_ERROR) {
1628 Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
1629 }
1630 return result;
1631 }
1632 while (1) {
1633 /*
1634 * We need to reset the result before passing it off to
1635 * Tcl_ExprBooleanObj. Otherwise, any error message will be appended
1636 * to the result of the last evaluation.
1637 */
1638
1639 Tcl_ResetResult(interp);
1640 result = Tcl_ExprBooleanObj(interp, objv[2], &value);
1641 if (result != TCL_OK) {
1642 return result;
1643 }
1644 if (!value) {
1645 break;
1646 }
1647
1648 /*
1649 * TIP #280. Make invoking context available to loop body.
1650 */
1651
1652 result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr, 4);
1653 if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
1654 if (result == TCL_ERROR) {
1655 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
1656 "\n (\"for\" body line %d)", interp->errorLine));
1657 }
1658 break;
1659 }
1660
1661 /*
1662 * TIP #280. Make invoking context available to next script.
1663 */
1664
1665 result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr, 3);
1666 if (result == TCL_BREAK) {
1667 break;
1668 } else if (result != TCL_OK) {
1669 if (result == TCL_ERROR) {
1670 Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
1671 }
1672 return result;
1673 }
1674 }
1675 if (result == TCL_BREAK) {
1676 result = TCL_OK;
1677 }
1678 if (result == TCL_OK) {
1679 Tcl_ResetResult(interp);
1680 }
1681 return result;
1682 }
1683
1684 /*
1685 *----------------------------------------------------------------------
1686 *
1687 * Tcl_ForeachObjCmd --
1688 *
1689 * This object-based procedure is invoked to process the "foreach" Tcl
1690 * command. See the user documentation for details on what it does.
1691 *
1692 * Results:
1693 * A standard Tcl object result.
1694 *
1695 * Side effects:
1696 * See the user documentation.
1697 *
1698 *----------------------------------------------------------------------
1699 */
1700
1701 /* ARGSUSED */
1702 int
Tcl_ForeachObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1703 Tcl_ForeachObjCmd(
1704 ClientData dummy, /* Not used. */
1705 Tcl_Interp *interp, /* Current interpreter. */
1706 int objc, /* Number of arguments. */
1707 Tcl_Obj *const objv[]) /* Argument objects. */
1708 {
1709 int result = TCL_OK;
1710 int i; /* i selects a value list */
1711 int j, maxj; /* Number of loop iterations */
1712 int v; /* v selects a loop variable */
1713 int numLists = (objc-2)/2; /* Count of value lists */
1714 Tcl_Obj *bodyPtr;
1715 Interp *iPtr = (Interp *) interp;
1716
1717 int *index; /* Array of value list indices */
1718 int *varcList; /* # loop variables per list */
1719 Tcl_Obj ***varvList; /* Array of var name lists */
1720 Tcl_Obj **vCopyList; /* Copies of var name list arguments */
1721 int *argcList; /* Array of value list sizes */
1722 Tcl_Obj ***argvList; /* Array of value lists */
1723 Tcl_Obj **aCopyList; /* Copies of value list arguments */
1724
1725 if (objc < 4 || (objc%2 != 0)) {
1726 Tcl_WrongNumArgs(interp, 1, objv,
1727 "varList list ?varList list ...? command");
1728 return TCL_ERROR;
1729 }
1730
1731 /*
1732 * Manage numList parallel value lists.
1733 * argvList[i] is a value list counted by argcList[i]l;
1734 * varvList[i] is the list of variables associated with the value list;
1735 * varcList[i] is the number of variables associated with the value list;
1736 * index[i] is the current pointer into the value list argvList[i].
1737 */
1738
1739 index = (int *) TclStackAlloc(interp, 3 * numLists * sizeof(int));
1740 varcList = index + numLists;
1741 argcList = varcList + numLists;
1742 memset(index, 0, 3 * numLists * sizeof(int));
1743
1744 varvList = (Tcl_Obj ***)
1745 TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj **));
1746 argvList = varvList + numLists;
1747 memset(varvList, 0, 2 * numLists * sizeof(Tcl_Obj **));
1748
1749 vCopyList = (Tcl_Obj **)
1750 TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj *));
1751 aCopyList = vCopyList + numLists;
1752 memset(vCopyList, 0, 2 * numLists * sizeof(Tcl_Obj *));
1753
1754 /*
1755 * Break up the value lists and variable lists into elements.
1756 */
1757
1758 maxj = 0;
1759 for (i=0 ; i<numLists ; i++) {
1760
1761 vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
1762 if (vCopyList[i] == NULL) {
1763 result = TCL_ERROR;
1764 goto done;
1765 }
1766 TclListObjGetElements(NULL, vCopyList[i], &varcList[i], &varvList[i]);
1767 if (varcList[i] < 1) {
1768 Tcl_AppendResult(interp, "foreach varlist is empty", NULL);
1769 result = TCL_ERROR;
1770 goto done;
1771 }
1772
1773 aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
1774 if (aCopyList[i] == NULL) {
1775 result = TCL_ERROR;
1776 goto done;
1777 }
1778 TclListObjGetElements(NULL, aCopyList[i], &argcList[i], &argvList[i]);
1779
1780 j = argcList[i] / varcList[i];
1781 if ((argcList[i] % varcList[i]) != 0) {
1782 j++;
1783 }
1784 if (j > maxj) {
1785 maxj = j;
1786 }
1787 }
1788
1789 /*
1790 * Iterate maxj times through the lists in parallel. If some value lists
1791 * run out of values, set loop vars to ""
1792 */
1793
1794 bodyPtr = objv[objc-1];
1795 for (j=0 ; j<maxj ; j++) {
1796 for (i=0 ; i<numLists ; i++) {
1797 for (v=0 ; v<varcList[i] ; v++) {
1798 int k = index[i]++;
1799 Tcl_Obj *valuePtr, *varValuePtr;
1800
1801 if (k < argcList[i]) {
1802 valuePtr = argvList[i][k];
1803 } else {
1804 valuePtr = Tcl_NewObj(); /* Empty string */
1805 }
1806 varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL,
1807 valuePtr, TCL_LEAVE_ERR_MSG);
1808 if (varValuePtr == NULL) {
1809 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
1810 "\n (setting foreach loop variable \"%s\")",
1811 TclGetString(varvList[i][v])));
1812 result = TCL_ERROR;
1813 goto done;
1814 }
1815 }
1816 }
1817
1818 /*
1819 * TIP #280. Make invoking context available to loop body.
1820 */
1821
1822 result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr, objc-1);
1823 if (result != TCL_OK) {
1824 if (result == TCL_CONTINUE) {
1825 result = TCL_OK;
1826 } else if (result == TCL_BREAK) {
1827 result = TCL_OK;
1828 break;
1829 } else if (result == TCL_ERROR) {
1830 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
1831 "\n (\"foreach\" body line %d)",
1832 interp->errorLine));
1833 break;
1834 } else {
1835 break;
1836 }
1837 }
1838 }
1839 if (result == TCL_OK) {
1840 Tcl_ResetResult(interp);
1841 }
1842
1843 done:
1844 for (i=0 ; i<numLists ; i++) {
1845 if (vCopyList[i]) {
1846 Tcl_DecrRefCount(vCopyList[i]);
1847 }
1848 if (aCopyList[i]) {
1849 Tcl_DecrRefCount(aCopyList[i]);
1850 }
1851 }
1852 TclStackFree(interp, vCopyList); /* Tcl_Obj * arrays */
1853 TclStackFree(interp, varvList); /* Tcl_Obj ** arrays */
1854 TclStackFree(interp, index); /* int arrays */
1855 return result;
1856 }
1857
1858 /*
1859 *----------------------------------------------------------------------
1860 *
1861 * Tcl_FormatObjCmd --
1862 *
1863 * This procedure is invoked to process the "format" Tcl command. See
1864 * the user documentation for details on what it does.
1865 *
1866 * Results:
1867 * A standard Tcl result.
1868 *
1869 * Side effects:
1870 * See the user documentation.
1871 *
1872 *----------------------------------------------------------------------
1873 */
1874
1875 /* ARGSUSED */
1876 int
Tcl_FormatObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1877 Tcl_FormatObjCmd(
1878 ClientData dummy, /* Not used. */
1879 Tcl_Interp *interp, /* Current interpreter. */
1880 int objc, /* Number of arguments. */
1881 Tcl_Obj *const objv[]) /* Argument objects. */
1882 {
1883 Tcl_Obj *resultPtr; /* Where result is stored finally. */
1884
1885 if (objc < 2) {
1886 Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
1887 return TCL_ERROR;
1888 }
1889
1890 resultPtr = Tcl_Format(interp, TclGetString(objv[1]), objc-2, objv+2);
1891 if (resultPtr == NULL) {
1892 return TCL_ERROR;
1893 }
1894 Tcl_SetObjResult(interp, resultPtr);
1895 return TCL_OK;
1896 }
1897
1898 /*
1899 * Local Variables:
1900 * mode: c
1901 * c-basic-offset: 4
1902 * fill-column: 78
1903 * End:
1904 */
1905