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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25