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