/[dtapublic]/to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclfcmd.c
ViewVC logotype

Contents of /to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclfcmd.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 29 - (show annotations) (download)
Sat Oct 8 07:08:47 2016 UTC (7 years, 7 months ago) by dashley
File MIME type: text/plain
File size: 24081 byte(s)
Directories relocated.
1 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclfcmd.c,v 1.1.1.1 2001/06/13 04:39:01 dtashley Exp $ */
2
3 /*
4 * tclFCmd.c
5 *
6 * This file implements the generic portion of file manipulation
7 * subcommands of the "file" command.
8 *
9 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
10 *
11 * See the file "license.terms" for information on usage and redistribution
12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 *
14 * RCS: @(#) $Id: tclfcmd.c,v 1.1.1.1 2001/06/13 04:39:01 dtashley Exp $
15 */
16
17 #include "tclInt.h"
18 #include "tclPort.h"
19
20 /*
21 * Declarations for local procedures defined in this file:
22 */
23
24 static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
25 char *source, char *dest, int copyFlag,
26 int force));
27 static char * FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
28 char *path, Tcl_DString *bufferPtr));
29 static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
30 int argc, char **argv, int copyFlag));
31 static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
32 int argc, char **argv, int *forcePtr));
33
34 /*
35 *---------------------------------------------------------------------------
36 *
37 * TclFileRenameCmd
38 *
39 * This procedure implements the "rename" subcommand of the "file"
40 * command. Filename arguments need to be translated to native
41 * format before being passed to platform-specific code that
42 * implements rename functionality.
43 *
44 * Results:
45 * A standard Tcl result.
46 *
47 * Side effects:
48 * See the user documentation.
49 *
50 *---------------------------------------------------------------------------
51 */
52
53 int
54 TclFileRenameCmd(interp, argc, argv)
55 Tcl_Interp *interp; /* Interp for error reporting. */
56 int argc; /* Number of arguments. */
57 char **argv; /* Argument strings passed to Tcl_FileCmd. */
58 {
59 return FileCopyRename(interp, argc, argv, 0);
60 }
61
62 /*
63 *---------------------------------------------------------------------------
64 *
65 * TclFileCopyCmd
66 *
67 * This procedure implements the "copy" subcommand of the "file"
68 * command. Filename arguments need to be translated to native
69 * format before being passed to platform-specific code that
70 * implements copy functionality.
71 *
72 * Results:
73 * A standard Tcl result.
74 *
75 * Side effects:
76 * See the user documentation.
77 *
78 *---------------------------------------------------------------------------
79 */
80
81 int
82 TclFileCopyCmd(interp, argc, argv)
83 Tcl_Interp *interp; /* Used for error reporting */
84 int argc; /* Number of arguments. */
85 char **argv; /* Argument strings passed to Tcl_FileCmd. */
86 {
87 return FileCopyRename(interp, argc, argv, 1);
88 }
89
90 /*
91 *---------------------------------------------------------------------------
92 *
93 * FileCopyRename --
94 *
95 * Performs the work of TclFileRenameCmd and TclFileCopyCmd.
96 * See comments for those procedures.
97 *
98 * Results:
99 * See above.
100 *
101 * Side effects:
102 * See above.
103 *
104 *---------------------------------------------------------------------------
105 */
106
107 static int
108 FileCopyRename(interp, argc, argv, copyFlag)
109 Tcl_Interp *interp; /* Used for error reporting. */
110 int argc; /* Number of arguments. */
111 char **argv; /* Argument strings passed to Tcl_FileCmd. */
112 int copyFlag; /* If non-zero, copy source(s). Otherwise,
113 * rename them. */
114 {
115 int i, result, force;
116 struct stat statBuf;
117 Tcl_DString targetBuffer;
118 char *target;
119
120 i = FileForceOption(interp, argc - 2, argv + 2, &force);
121 if (i < 0) {
122 return TCL_ERROR;
123 }
124 i += 2;
125 if ((argc - i) < 2) {
126 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
127 " ", argv[1], " ?options? source ?source ...? target\"",
128 (char *) NULL);
129 return TCL_ERROR;
130 }
131
132 /*
133 * If target doesn't exist or isn't a directory, try the copy/rename.
134 * More than 2 arguments is only valid if the target is an existing
135 * directory.
136 */
137
138 target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer);
139 if (target == NULL) {
140 return TCL_ERROR;
141 }
142
143 result = TCL_OK;
144
145 /*
146 * Call TclStat() so that if target is a symlink that points to a
147 * directory we will put the sources in that directory instead of
148 * overwriting the symlink.
149 */
150
151 if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
152 if ((argc - i) > 2) {
153 errno = ENOTDIR;
154 Tcl_PosixError(interp);
155 Tcl_AppendResult(interp, "error ",
156 ((copyFlag) ? "copying" : "renaming"), ": target \"",
157 argv[argc - 1], "\" is not a directory", (char *) NULL);
158 result = TCL_ERROR;
159 } else {
160 /*
161 * Even though already have target == translated(argv[i+1]),
162 * pass the original argument down, so if there's an error, the
163 * error message will reflect the original arguments.
164 */
165
166 result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag,
167 force);
168 }
169 Tcl_DStringFree(&targetBuffer);
170 return result;
171 }
172
173 /*
174 * Move each source file into target directory. Extract the basename
175 * from each source, and append it to the end of the target path.
176 */
177
178 for ( ; i < argc - 1; i++) {
179 char *jargv[2];
180 char *source, *newFileName;
181 Tcl_DString sourceBuffer, newFileNameBuffer;
182
183 source = FileBasename(interp, argv[i], &sourceBuffer);
184 if (source == NULL) {
185 result = TCL_ERROR;
186 break;
187 }
188 jargv[0] = argv[argc - 1];
189 jargv[1] = source;
190 Tcl_DStringInit(&newFileNameBuffer);
191 newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer);
192 result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag,
193 force);
194 Tcl_DStringFree(&sourceBuffer);
195 Tcl_DStringFree(&newFileNameBuffer);
196
197 if (result == TCL_ERROR) {
198 break;
199 }
200 }
201 Tcl_DStringFree(&targetBuffer);
202 return result;
203 }
204
205 /*
206 *---------------------------------------------------------------------------
207 *
208 * TclFileMakeDirsCmd
209 *
210 * This procedure implements the "mkdir" subcommand of the "file"
211 * command. Filename arguments need to be translated to native
212 * format before being passed to platform-specific code that
213 * implements mkdir functionality.
214 *
215 * Results:
216 * A standard Tcl result.
217 *
218 * Side effects:
219 * See the user documentation.
220 *
221 *----------------------------------------------------------------------
222 */
223 int
224 TclFileMakeDirsCmd(interp, argc, argv)
225 Tcl_Interp *interp; /* Used for error reporting. */
226 int argc; /* Number of arguments */
227 char **argv; /* Argument strings passed to Tcl_FileCmd. */
228 {
229 Tcl_DString nameBuffer, targetBuffer;
230 char *errfile;
231 int result, i, j, pargc;
232 char **pargv;
233 struct stat statBuf;
234
235 pargv = NULL;
236 errfile = NULL;
237 Tcl_DStringInit(&nameBuffer);
238 Tcl_DStringInit(&targetBuffer);
239
240 result = TCL_OK;
241 for (i = 2; i < argc; i++) {
242 char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
243 if (name == NULL) {
244 result = TCL_ERROR;
245 break;
246 }
247
248 Tcl_SplitPath(name, &pargc, &pargv);
249 if (pargc == 0) {
250 errno = ENOENT;
251 errfile = argv[i];
252 break;
253 }
254 for (j = 0; j < pargc; j++) {
255 char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer);
256
257 /*
258 * Call TclStat() so that if target is a symlink that points
259 * to a directory we will create subdirectories in that
260 * directory.
261 */
262
263 if (TclStat(target, &statBuf) == 0) {
264 if (!S_ISDIR(statBuf.st_mode)) {
265 errno = EEXIST;
266 errfile = target;
267 goto done;
268 }
269 } else if ((errno != ENOENT)
270 || (TclpCreateDirectory(target) != TCL_OK)) {
271 errfile = target;
272 goto done;
273 }
274 Tcl_DStringFree(&targetBuffer);
275 }
276 ckfree((char *) pargv);
277 pargv = NULL;
278 Tcl_DStringFree(&nameBuffer);
279 }
280
281 done:
282 if (errfile != NULL) {
283 Tcl_AppendResult(interp, "can't create directory \"",
284 errfile, "\": ", Tcl_PosixError(interp), (char *) NULL);
285 result = TCL_ERROR;
286 }
287
288 Tcl_DStringFree(&nameBuffer);
289 Tcl_DStringFree(&targetBuffer);
290 if (pargv != NULL) {
291 ckfree((char *) pargv);
292 }
293 return result;
294 }
295
296 /*
297 *----------------------------------------------------------------------
298 *
299 * TclFileDeleteCmd
300 *
301 * This procedure implements the "delete" subcommand of the "file"
302 * command.
303 *
304 * Results:
305 * A standard Tcl result.
306 *
307 * Side effects:
308 * See the user documentation.
309 *
310 *----------------------------------------------------------------------
311 */
312
313 int
314 TclFileDeleteCmd(interp, argc, argv)
315 Tcl_Interp *interp; /* Used for error reporting */
316 int argc; /* Number of arguments */
317 char **argv; /* Argument strings passed to Tcl_FileCmd. */
318 {
319 Tcl_DString nameBuffer, errorBuffer;
320 int i, force, result;
321 char *errfile;
322
323 i = FileForceOption(interp, argc - 2, argv + 2, &force);
324 if (i < 0) {
325 return TCL_ERROR;
326 }
327 i += 2;
328 if ((argc - i) < 1) {
329 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
330 " ", argv[1], " ?options? file ?file ...?\"", (char *) NULL);
331 return TCL_ERROR;
332 }
333
334 errfile = NULL;
335 result = TCL_OK;
336 Tcl_DStringInit(&errorBuffer);
337 Tcl_DStringInit(&nameBuffer);
338
339 for ( ; i < argc; i++) {
340 struct stat statBuf;
341 char *name;
342
343 errfile = argv[i];
344 Tcl_DStringSetLength(&nameBuffer, 0);
345 name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
346 if (name == NULL) {
347 result = TCL_ERROR;
348 goto done;
349 }
350
351 /*
352 * Call lstat() to get info so can delete symbolic link itself.
353 */
354
355 if (TclpLstat(name, &statBuf) != 0) {
356 /*
357 * Trying to delete a file that does not exist is not
358 * considered an error, just a no-op
359 */
360
361 if (errno != ENOENT) {
362 result = TCL_ERROR;
363 }
364 } else if (S_ISDIR(statBuf.st_mode)) {
365 result = TclpRemoveDirectory(name, force, &errorBuffer);
366 if (result != TCL_OK) {
367 if ((force == 0) && (errno == EEXIST)) {
368 Tcl_AppendResult(interp, "error deleting \"", argv[i],
369 "\": directory not empty", (char *) NULL);
370 Tcl_PosixError(interp);
371 goto done;
372 }
373
374 /*
375 * If possible, use the untranslated name for the file.
376 */
377
378 errfile = Tcl_DStringValue(&errorBuffer);
379 if (strcmp(name, errfile) == 0) {
380 errfile = argv[i];
381 }
382 }
383 } else {
384 result = TclpDeleteFile(name);
385 }
386
387 if (result == TCL_ERROR) {
388 break;
389 }
390 }
391 if (result != TCL_OK) {
392 Tcl_AppendResult(interp, "error deleting \"", errfile,
393 "\": ", Tcl_PosixError(interp), (char *) NULL);
394 }
395 done:
396 Tcl_DStringFree(&errorBuffer);
397 Tcl_DStringFree(&nameBuffer);
398 return result;
399 }
400
401 /*
402 *---------------------------------------------------------------------------
403 *
404 * CopyRenameOneFile
405 *
406 * Copies or renames specified source file or directory hierarchy
407 * to the specified target.
408 *
409 * Results:
410 * A standard Tcl result.
411 *
412 * Side effects:
413 * Target is overwritten if the force flag is set. Attempting to
414 * copy/rename a file onto a directory or a directory onto a file
415 * will always result in an error.
416 *
417 *----------------------------------------------------------------------
418 */
419
420 static int
421 CopyRenameOneFile(interp, source, target, copyFlag, force)
422 Tcl_Interp *interp; /* Used for error reporting. */
423 char *source; /* Pathname of file to copy. May need to
424 * be translated. */
425 char *target; /* Pathname of file to create/overwrite.
426 * May need to be translated. */
427 int copyFlag; /* If non-zero, copy files. Otherwise,
428 * rename them. */
429 int force; /* If non-zero, overwrite target file if it
430 * exists. Otherwise, error if target already
431 * exists. */
432 {
433 int result;
434 Tcl_DString sourcePath, targetPath, errorBuffer;
435 char *targetName, *sourceName, *errfile;
436 struct stat sourceStatBuf, targetStatBuf;
437
438 sourceName = Tcl_TranslateFileName(interp, source, &sourcePath);
439 if (sourceName == NULL) {
440 return TCL_ERROR;
441 }
442 targetName = Tcl_TranslateFileName(interp, target, &targetPath);
443 if (targetName == NULL) {
444 Tcl_DStringFree(&sourcePath);
445 return TCL_ERROR;
446 }
447
448 errfile = NULL;
449 result = TCL_ERROR;
450 Tcl_DStringInit(&errorBuffer);
451
452 /*
453 * We want to copy/rename links and not the files they point to, so we
454 * use lstat(). If target is a link, we also want to replace the
455 * link and not the file it points to, so we also use lstat() on the
456 * target.
457 */
458
459 if (TclpLstat(sourceName, &sourceStatBuf) != 0) {
460 errfile = source;
461 goto done;
462 }
463 if (TclpLstat(targetName, &targetStatBuf) != 0) {
464 if (errno != ENOENT) {
465 errfile = target;
466 goto done;
467 }
468 } else {
469 if (force == 0) {
470 errno = EEXIST;
471 errfile = target;
472 goto done;
473 }
474
475 /*
476 * Prevent copying or renaming a file onto itself. Under Windows,
477 * stat always returns 0 for st_ino. However, the Windows-specific
478 * code knows how to deal with copying or renaming a file on top of
479 * itself. It might be a good idea to write a stat that worked.
480 */
481
482 if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
483 if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
484 (sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
485 result = TCL_OK;
486 goto done;
487 }
488 }
489
490 /*
491 * Prevent copying/renaming a file onto a directory and
492 * vice-versa. This is a policy decision based on the fact that
493 * existing implementations of copy and rename on all platforms
494 * also prevent this.
495 */
496
497 if (S_ISDIR(sourceStatBuf.st_mode)
498 && !S_ISDIR(targetStatBuf.st_mode)) {
499 errno = EISDIR;
500 Tcl_AppendResult(interp, "can't overwrite file \"", target,
501 "\" with directory \"", source, "\"", (char *) NULL);
502 goto done;
503 }
504 if (!S_ISDIR(sourceStatBuf.st_mode)
505 && S_ISDIR(targetStatBuf.st_mode)) {
506 errno = EISDIR;
507 Tcl_AppendResult(interp, "can't overwrite directory \"", target,
508 "\" with file \"", source, "\"", (char *) NULL);
509 goto done;
510 }
511 }
512
513 if (copyFlag == 0) {
514 result = TclpRenameFile(sourceName, targetName);
515 if (result == TCL_OK) {
516 goto done;
517 }
518
519 if (errno == EINVAL) {
520 Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"",
521 target, "\": trying to rename a volume or ",
522 "move a directory into itself", (char *) NULL);
523 goto done;
524 } else if (errno != EXDEV) {
525 errfile = target;
526 goto done;
527 }
528
529 /*
530 * The rename failed because the move was across file systems.
531 * Fall through to copy file and then remove original. Note that
532 * the low-level TclpRenameFile is allowed to implement
533 * cross-filesystem moves itself.
534 */
535 }
536
537 if (S_ISDIR(sourceStatBuf.st_mode)) {
538 result = TclpCopyDirectory(sourceName, targetName, &errorBuffer);
539 if (result != TCL_OK) {
540 errfile = Tcl_DStringValue(&errorBuffer);
541 if (strcmp(errfile, sourceName) == 0) {
542 errfile = source;
543 } else if (strcmp(errfile, targetName) == 0) {
544 errfile = target;
545 }
546 }
547 } else {
548 result = TclpCopyFile(sourceName, targetName);
549 if (result != TCL_OK) {
550 /*
551 * Well, there really shouldn't be a problem with source,
552 * because up there we checked to see if it was ok to copy it.
553 */
554
555 errfile = target;
556 }
557 }
558 if ((copyFlag == 0) && (result == TCL_OK)) {
559 if (S_ISDIR(sourceStatBuf.st_mode)) {
560 result = TclpRemoveDirectory(sourceName, 1, &errorBuffer);
561 if (result != TCL_OK) {
562 errfile = Tcl_DStringValue(&errorBuffer);
563 if (strcmp(errfile, sourceName) == 0) {
564 errfile = source;
565 }
566 }
567 } else {
568 result = TclpDeleteFile(sourceName);
569 if (result != TCL_OK) {
570 errfile = source;
571 }
572 }
573 if (result != TCL_OK) {
574 Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ",
575 Tcl_PosixError(interp), (char *) NULL);
576 errfile = NULL;
577 }
578 }
579
580 done:
581 if (errfile != NULL) {
582 Tcl_AppendResult(interp,
583 ((copyFlag) ? "error copying \"" : "error renaming \""),
584 source, (char *) NULL);
585 if (errfile != source) {
586 Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL);
587 if (errfile != target) {
588 Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL);
589 }
590 }
591 Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
592 (char *) NULL);
593 }
594 Tcl_DStringFree(&errorBuffer);
595 Tcl_DStringFree(&sourcePath);
596 Tcl_DStringFree(&targetPath);
597 return result;
598 }
599
600 /*
601 *---------------------------------------------------------------------------
602 *
603 * FileForceOption --
604 *
605 * Helps parse command line options for file commands that take
606 * the "-force" and "--" options.
607 *
608 * Results:
609 * The return value is how many arguments from argv were consumed
610 * by this function, or -1 if there was an error parsing the
611 * options. If an error occurred, an error message is left in the
612 * interp's result.
613 *
614 * Side effects:
615 * None.
616 *
617 *---------------------------------------------------------------------------
618 */
619
620 static int
621 FileForceOption(interp, argc, argv, forcePtr)
622 Tcl_Interp *interp; /* Interp, for error return. */
623 int argc; /* Number of arguments. */
624 char **argv; /* Argument strings. First command line
625 * option, if it exists, begins at 0. */
626 int *forcePtr; /* If the "-force" was specified, *forcePtr
627 * is filled with 1, otherwise with 0. */
628 {
629 int force, i;
630
631 force = 0;
632 for (i = 0; i < argc; i++) {
633 if (argv[i][0] != '-') {
634 break;
635 }
636 if (strcmp(argv[i], "-force") == 0) {
637 force = 1;
638 } else if (strcmp(argv[i], "--") == 0) {
639 i++;
640 break;
641 } else {
642 Tcl_AppendResult(interp, "bad option \"", argv[i],
643 "\": should be -force or --", (char *)NULL);
644 return -1;
645 }
646 }
647 *forcePtr = force;
648 return i;
649 }
650 /*
651 *---------------------------------------------------------------------------
652 *
653 * FileBasename --
654 *
655 * Given a path in either tcl format (with / separators), or in the
656 * platform-specific format for the current platform, return all the
657 * characters in the path after the last directory separator. But,
658 * if path is the root directory, returns no characters.
659 *
660 * Results:
661 * Appends the string that represents the basename to the end of
662 * the specified initialized DString, returning a pointer to the
663 * resulting string. If there is an error, an error message is left
664 * in interp, NULL is returned, and the Tcl_DString is unmodified.
665 *
666 * Side effects:
667 * None.
668 *
669 *---------------------------------------------------------------------------
670 */
671
672 static char *
673 FileBasename(interp, path, bufferPtr)
674 Tcl_Interp *interp; /* Interp, for error return. */
675 char *path; /* Path whose basename to extract. */
676 Tcl_DString *bufferPtr; /* Initialized DString that receives
677 * basename. */
678 {
679 int argc;
680 char **argv;
681
682 Tcl_SplitPath(path, &argc, &argv);
683 if (argc == 0) {
684 Tcl_DStringInit(bufferPtr);
685 } else {
686 if ((argc == 1) && (*path == '~')) {
687 Tcl_DString buffer;
688
689 ckfree((char *) argv);
690 path = Tcl_TranslateFileName(interp, path, &buffer);
691 if (path == NULL) {
692 return NULL;
693 }
694 Tcl_SplitPath(path, &argc, &argv);
695 Tcl_DStringFree(&buffer);
696 }
697 Tcl_DStringInit(bufferPtr);
698
699 /*
700 * Return the last component, unless it is the only component, and it
701 * is the root of an absolute path.
702 */
703
704 if (argc > 0) {
705 if ((argc > 1)
706 || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
707 Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1);
708 }
709 }
710 }
711 ckfree((char *) argv);
712 return Tcl_DStringValue(bufferPtr);
713 }
714
715 /*
716 *----------------------------------------------------------------------
717 *
718 * TclFileAttrsCmd --
719 *
720 * Sets or gets the platform-specific attributes of a file. The objc-objv
721 * points to the file name with the rest of the command line following.
722 * This routine uses platform-specific tables of option strings
723 * and callbacks. The callback to get the attributes take three
724 * parameters:
725 * Tcl_Interp *interp; The interp to report errors with.
726 * Since this is an object-based API,
727 * the object form of the result should be
728 * used.
729 * CONST char *fileName; This is extracted using
730 * Tcl_TranslateFileName.
731 * TclObj **attrObjPtrPtr; A new object to hold the attribute
732 * is allocated and put here.
733 * The first two parameters of the callback used to write out the
734 * attributes are the same. The third parameter is:
735 * CONST *attrObjPtr; A pointer to the object that has
736 * the new attribute.
737 * They both return standard TCL errors; if the routine to get
738 * an attribute fails, no object is allocated and *attrObjPtrPtr
739 * is unchanged.
740 *
741 * Results:
742 * Standard TCL error.
743 *
744 * Side effects:
745 * May set file attributes for the file name.
746 *
747 *----------------------------------------------------------------------
748 */
749
750 int
751 TclFileAttrsCmd(interp, objc, objv)
752 Tcl_Interp *interp; /* The interpreter for error reporting. */
753 int objc; /* Number of command line arguments. */
754 Tcl_Obj *CONST objv[]; /* The command line objects. */
755 {
756 char *fileName;
757 int result;
758 Tcl_DString buffer;
759
760 if (objc < 3) {
761 Tcl_WrongNumArgs(interp, 2, objv,
762 "name ?option? ?value? ?option value ...?");
763 return TCL_ERROR;
764 }
765
766 fileName = Tcl_GetString(objv[2]);
767 fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
768 if (fileName == NULL) {
769 return TCL_ERROR;
770 }
771
772 objc -= 3;
773 objv += 3;
774 result = TCL_ERROR;
775
776 if (objc == 0) {
777 /*
778 * Get all attributes.
779 */
780
781 int index;
782 Tcl_Obj *listPtr, *objPtr;
783
784 listPtr = Tcl_NewListObj(0, NULL);
785 for (index = 0; tclpFileAttrStrings[index] != NULL; index++) {
786 objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1);
787 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
788
789 if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
790 &objPtr) != TCL_OK) {
791 Tcl_DecrRefCount(listPtr);
792 goto end;
793 }
794 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
795 }
796 Tcl_SetObjResult(interp, listPtr);
797 } else if (objc == 1) {
798 /*
799 * Get one attribute.
800 */
801
802 int index;
803 Tcl_Obj *objPtr;
804
805 if (Tcl_GetIndexFromObj(interp, objv[0], tclpFileAttrStrings,
806 "option", 0, &index) != TCL_OK) {
807 goto end;
808 }
809 if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
810 &objPtr) != TCL_OK) {
811 goto end;
812 }
813 Tcl_SetObjResult(interp, objPtr);
814 } else {
815 /*
816 * Set option/value pairs.
817 */
818
819 int i, index;
820
821 for (i = 0; i < objc ; i += 2) {
822 if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings,
823 "option", 0, &index) != TCL_OK) {
824 goto end;
825 }
826 if (i + 1 == objc) {
827 Tcl_AppendResult(interp, "value for \"",
828 Tcl_GetString(objv[i]), "\" missing",
829 (char *) NULL);
830 goto end;
831 }
832 if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName,
833 objv[i + 1]) != TCL_OK) {
834 goto end;
835 }
836 }
837 }
838 result = TCL_OK;
839
840 end:
841 Tcl_DStringFree(&buffer);
842 return result;
843 }
844
845
846 /* $History: tclfcmd.c $
847 *
848 * ***************** Version 1 *****************
849 * User: Dtashley Date: 1/02/01 Time: 1:31a
850 * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
851 * Initial check-in.
852 */
853
854 /* End of TCLFCMD.C */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25