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

Annotation of /projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclfcmd.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (hide annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (7 years, 10 months ago) by dashley
Original Path: sf_code/esrgpcpj/shared/tcl_base/tclfcmd.c
File MIME type: text/plain
File size: 24081 byte(s)
Initial commit.
1 dashley 25 /* $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