OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclFCmd.c] - Blame information for rev 1774

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.