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

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclIOUtil.c] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
/*
2
 * tclIOUtil.c --
3
 *
4
 *      This file contains a collection of utility procedures that
5
 *      are shared by the platform specific IO drivers.
6
 *
7
 *      Parts of this file are based on code contributed by Karl
8
 *      Lehenbauer, Mark Diekhans and Peter da Silva.
9
 *
10
 * Copyright (c) 1991-1994 The Regents of the University of California.
11
 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
12
 *
13
 * See the file "license.terms" for information on usage and redistribution
14
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15
 *
16
 * RCS: @(#) $Id: tclIOUtil.c,v 1.1.1.1 2002-01-16 10:25:27 markom Exp $
17
 */
18
 
19
#include "tclInt.h"
20
#include "tclPort.h"
21
 
22
/*
23
 * The following typedef declarations allow for hooking into the chain
24
 * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
25
 * 'Tcl_OpenFileChannel(...)'.  Basically for each hookable function
26
 * a linked list is defined.
27
 */
28
 
29
typedef struct StatProc {
30
    TclStatProc_ *proc;          /* Function to process a 'stat()' call */
31
    struct StatProc *nextPtr;    /* The next 'stat()' function to call */
32
} StatProc;
33
 
34
typedef struct AccessProc {
35
    TclAccessProc_ *proc;        /* Function to process a 'access()' call */
36
    struct AccessProc *nextPtr;  /* The next 'access()' function to call */
37
} AccessProc;
38
 
39
typedef struct OpenFileChannelProc {
40
    TclOpenFileChannelProc_ *proc;  /* Function to process a
41
                                     * 'Tcl_OpenFileChannel()' call */
42
    struct OpenFileChannelProc *nextPtr;
43
                                    /* The next 'Tcl_OpenFileChannel()'
44
                                     * function to call */
45
} OpenFileChannelProc;
46
 
47
/*
48
 * For each type of hookable function, a static node is declared to
49
 * hold the function pointer for the "built-in" routine (e.g.
50
 * 'TclpStat(...)') and the respective list is initialized as a pointer
51
 * to that node.
52
 *
53
 * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that
54
 * these statically declared list entry cannot be inadvertently removed.
55
 *
56
 * This method avoids the need to call any sort of "initialization"
57
 * function
58
 */
59
 
60
static StatProc defaultStatProc = {
61
    &TclpStat, NULL
62
};
63
static StatProc *statProcList = &defaultStatProc;
64
 
65
static AccessProc defaultAccessProc = {
66
    &TclpAccess, NULL
67
};
68
static AccessProc *accessProcList = &defaultAccessProc;
69
 
70
static OpenFileChannelProc defaultOpenFileChannelProc = {
71
    &TclpOpenFileChannel, NULL
72
};
73
static OpenFileChannelProc *openFileChannelProcList =
74
        &defaultOpenFileChannelProc;
75
 
76
/*
77
 *----------------------------------------------------------------------
78
 *
79
 * TclGetOpenMode --
80
 *
81
 * Description:
82
 *      Computes a POSIX mode mask for opening a file, from a given string,
83
 *      and also sets a flag to indicate whether the caller should seek to
84
 *      EOF after opening the file.
85
 *
86
 * Results:
87
 *      On success, returns mode to pass to "open". If an error occurs, the
88
 *      returns -1 and if interp is not NULL, sets interp->result to an
89
 *      error message.
90
 *
91
 * Side effects:
92
 *      Sets the integer referenced by seekFlagPtr to 1 to tell the caller
93
 *      to seek to EOF after opening the file.
94
 *
95
 * Special note:
96
 *      This code is based on a prototype implementation contributed
97
 *      by Mark Diekhans.
98
 *
99
 *----------------------------------------------------------------------
100
 */
101
 
102
int
103
TclGetOpenMode(interp, string, seekFlagPtr)
104
    Tcl_Interp *interp;                 /* Interpreter to use for error
105
                                         * reporting - may be NULL. */
106
    char *string;                       /* Mode string, e.g. "r+" or
107
                                         * "RDONLY CREAT". */
108
    int *seekFlagPtr;                   /* Set this to 1 if the caller
109
                                         * should seek to EOF during the
110
                                         * opening of the file. */
111
{
112
    int mode, modeArgc, c, i, gotRW;
113
    char **modeArgv, *flag;
114
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
115
 
116
    /*
117
     * Check for the simpler fopen-like access modes (e.g. "r").  They
118
     * are distinguished from the POSIX access modes by the presence
119
     * of a lower-case first letter.
120
     */
121
 
122
    *seekFlagPtr = 0;
123
    mode = 0;
124
    if (islower(UCHAR(string[0]))) {
125
        switch (string[0]) {
126
            case 'r':
127
                mode = O_RDONLY;
128
                break;
129
            case 'w':
130
                mode = O_WRONLY|O_CREAT|O_TRUNC;
131
                break;
132
            case 'a':
133
                mode = O_WRONLY|O_CREAT;
134
                *seekFlagPtr = 1;
135
                break;
136
            default:
137
                error:
138
                if (interp != (Tcl_Interp *) NULL) {
139
                    Tcl_AppendResult(interp,
140
                            "illegal access mode \"", string, "\"",
141
                            (char *) NULL);
142
                }
143
                return -1;
144
        }
145
        if (string[1] == '+') {
146
            mode &= ~(O_RDONLY|O_WRONLY);
147
            mode |= O_RDWR;
148
            if (string[2] != 0) {
149
                goto error;
150
            }
151
        } else if (string[1] != 0) {
152
            goto error;
153
        }
154
        return mode;
155
    }
156
 
157
    /*
158
     * The access modes are specified using a list of POSIX modes
159
     * such as O_CREAT.
160
     *
161
     * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when
162
     * a NULL interpreter is passed in.
163
     */
164
 
165
    if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
166
        if (interp != (Tcl_Interp *) NULL) {
167
            Tcl_AddErrorInfo(interp,
168
                    "\n    while processing open access modes \"");
169
            Tcl_AddErrorInfo(interp, string);
170
            Tcl_AddErrorInfo(interp, "\"");
171
        }
172
        return -1;
173
    }
174
 
175
    gotRW = 0;
176
    for (i = 0; i < modeArgc; i++) {
177
        flag = modeArgv[i];
178
        c = flag[0];
179
        if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
180
            mode = (mode & ~RW_MODES) | O_RDONLY;
181
            gotRW = 1;
182
        } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
183
            mode = (mode & ~RW_MODES) | O_WRONLY;
184
            gotRW = 1;
185
        } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
186
            mode = (mode & ~RW_MODES) | O_RDWR;
187
            gotRW = 1;
188
        } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
189
            mode |= O_APPEND;
190
            *seekFlagPtr = 1;
191
        } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
192
            mode |= O_CREAT;
193
        } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
194
            mode |= O_EXCL;
195
        } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
196
#ifdef O_NOCTTY
197
            mode |= O_NOCTTY;
198
#else
199
            if (interp != (Tcl_Interp *) NULL) {
200
                Tcl_AppendResult(interp, "access mode \"", flag,
201
                        "\" not supported by this system", (char *) NULL);
202
            }
203
            ckfree((char *) modeArgv);
204
            return -1;
205
#endif
206
        } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
207
#if defined(O_NDELAY) || defined(O_NONBLOCK)
208
#   ifdef O_NONBLOCK
209
            mode |= O_NONBLOCK;
210
#   else
211
            mode |= O_NDELAY;
212
#   endif
213
#else
214
            if (interp != (Tcl_Interp *) NULL) {
215
                Tcl_AppendResult(interp, "access mode \"", flag,
216
                        "\" not supported by this system", (char *) NULL);
217
            }
218
            ckfree((char *) modeArgv);
219
            return -1;
220
#endif
221
        } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
222
            mode |= O_TRUNC;
223
        } else {
224
            if (interp != (Tcl_Interp *) NULL) {
225
                Tcl_AppendResult(interp, "invalid access mode \"", flag,
226
                        "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
227
                        " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
228
            }
229
            ckfree((char *) modeArgv);
230
            return -1;
231
        }
232
    }
233
    ckfree((char *) modeArgv);
234
    if (!gotRW) {
235
        if (interp != (Tcl_Interp *) NULL) {
236
            Tcl_AppendResult(interp, "access mode must include either",
237
                    " RDONLY, WRONLY, or RDWR", (char *) NULL);
238
        }
239
        return -1;
240
    }
241
    return mode;
242
}
243
 
244
/*
245
 *----------------------------------------------------------------------
246
 *
247
 * Tcl_EvalFile --
248
 *
249
 *      Read in a file and process the entire file as one gigantic
250
 *      Tcl command.
251
 *
252
 * Results:
253
 *      A standard Tcl result, which is either the result of executing
254
 *      the file or an error indicating why the file couldn't be read.
255
 *
256
 * Side effects:
257
 *      Depends on the commands in the file.
258
 *
259
 *----------------------------------------------------------------------
260
 */
261
 
262
int
263
Tcl_EvalFile(interp, fileName)
264
    Tcl_Interp *interp;         /* Interpreter in which to process file. */
265
    char *fileName;             /* Name of file to process.  Tilde-substitution
266
                                 * will be performed on this name. */
267
{
268
    int result;
269
    struct stat statBuf;
270
    char *cmdBuffer = (char *) NULL;
271
    char *oldScriptFile;
272
    Interp *iPtr = (Interp *) interp;
273
    Tcl_DString buffer;
274
    char *nativeName;
275
    Tcl_Channel chan;
276
    Tcl_Obj *cmdObjPtr;
277
 
278
    Tcl_ResetResult(interp);
279
    oldScriptFile = iPtr->scriptFile;
280
    iPtr->scriptFile = fileName;
281
    Tcl_DStringInit(&buffer);
282
    nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
283
    if (nativeName == NULL) {
284
        goto error;
285
    }
286
 
287
    /*
288
     * If Tcl_TranslateFileName didn't already copy the file name, do it
289
     * here.  This way we don't depend on fileName staying constant
290
     * throughout the execution of the script (e.g., what if it happens
291
     * to point to a Tcl variable that the script could change?).
292
     */
293
 
294
    if (nativeName != Tcl_DStringValue(&buffer)) {
295
        Tcl_DStringSetLength(&buffer, 0);
296
        Tcl_DStringAppend(&buffer, nativeName, -1);
297
        nativeName = Tcl_DStringValue(&buffer);
298
    }
299
    if (TclStat(nativeName, &statBuf) == -1) {
300
        Tcl_SetErrno(errno);
301
        Tcl_AppendResult(interp, "couldn't read file \"", fileName,
302
                "\": ", Tcl_PosixError(interp), (char *) NULL);
303
        goto error;
304
    }
305
    chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644);
306
    if (chan == (Tcl_Channel) NULL) {
307
        Tcl_ResetResult(interp);
308
        Tcl_AppendResult(interp, "couldn't read file \"", fileName,
309
                "\": ", Tcl_PosixError(interp), (char *) NULL);
310
        goto error;
311
    }
312
    cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1);
313
    result = Tcl_Read(chan, cmdBuffer, statBuf.st_size);
314
    if (result < 0) {
315
        Tcl_Close(interp, chan);
316
        Tcl_AppendResult(interp, "couldn't read file \"", fileName,
317
                "\": ", Tcl_PosixError(interp), (char *) NULL);
318
        goto error;
319
    }
320
    cmdBuffer[result] = 0;
321
    if (Tcl_Close(interp, chan) != TCL_OK) {
322
        goto error;
323
    }
324
 
325
    /*
326
     * Transfer the buffer memory allocated above to the object system.
327
     * Tcl_EvalObj will own this new string object if needed,
328
     * so past the Tcl_EvalObj point, we must not ckfree(cmdBuffer)
329
     * but rather use the reference counting mechanism.
330
     * (Nb: and we must not thus not use goto error after this point)
331
     */
332
    cmdObjPtr = Tcl_NewObj();
333
    cmdObjPtr->bytes = cmdBuffer;
334
    cmdObjPtr->length = result;
335
 
336
    Tcl_IncrRefCount(cmdObjPtr);
337
    result = Tcl_EvalObj(interp, cmdObjPtr);
338
    Tcl_DecrRefCount(cmdObjPtr);
339
 
340
    if (result == TCL_RETURN) {
341
        result = TclUpdateReturnInfo(iPtr);
342
    } else if (result == TCL_ERROR) {
343
        char msg[200];
344
 
345
        /*
346
         * Record information telling where the error occurred.
347
         */
348
 
349
        sprintf(msg, "\n    (file \"%.150s\" line %d)", fileName,
350
                interp->errorLine);
351
        Tcl_AddErrorInfo(interp, msg);
352
    }
353
    iPtr->scriptFile = oldScriptFile;
354
    Tcl_DStringFree(&buffer);
355
    return result;
356
 
357
error:
358
    if (cmdBuffer != (char *) NULL) {
359
        ckfree(cmdBuffer);
360
    }
361
    iPtr->scriptFile = oldScriptFile;
362
    Tcl_DStringFree(&buffer);
363
    return TCL_ERROR;
364
}
365
 
366
/*
367
 *----------------------------------------------------------------------
368
 *
369
 * Tcl_GetErrno --
370
 *
371
 *      Gets the current value of the Tcl error code variable. This is
372
 *      currently the global variable "errno" but could in the future
373
 *      change to something else.
374
 *
375
 * Results:
376
 *      The value of the Tcl error code variable.
377
 *
378
 * Side effects:
379
 *      None. Note that the value of the Tcl error code variable is
380
 *      UNDEFINED if a call to Tcl_SetErrno did not precede this call.
381
 *
382
 *----------------------------------------------------------------------
383
 */
384
 
385
int
386
Tcl_GetErrno()
387
{
388
    return errno;
389
}
390
 
391
/*
392
 *----------------------------------------------------------------------
393
 *
394
 * Tcl_SetErrno --
395
 *
396
 *      Sets the Tcl error code variable to the supplied value.
397
 *
398
 * Results:
399
 *      None.
400
 *
401
 * Side effects:
402
 *      Modifies the value of the Tcl error code variable.
403
 *
404
 *----------------------------------------------------------------------
405
 */
406
 
407
void
408
Tcl_SetErrno(err)
409
    int err;                    /* The new value. */
410
{
411
    errno = err;
412
}
413
 
414
/*
415
 *----------------------------------------------------------------------
416
 *
417
 * Tcl_PosixError --
418
 *
419
 *      This procedure is typically called after UNIX kernel calls
420
 *      return errors.  It stores machine-readable information about
421
 *      the error in $errorCode returns an information string for
422
 *      the caller's use.
423
 *
424
 * Results:
425
 *      The return value is a human-readable string describing the
426
 *      error.
427
 *
428
 * Side effects:
429
 *      The global variable $errorCode is reset.
430
 *
431
 *----------------------------------------------------------------------
432
 */
433
 
434
char *
435
Tcl_PosixError(interp)
436
    Tcl_Interp *interp;         /* Interpreter whose $errorCode variable
437
                                 * is to be changed. */
438
{
439
    char *id, *msg;
440
 
441
    msg = Tcl_ErrnoMsg(errno);
442
    id = Tcl_ErrnoId();
443
    Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
444
    return msg;
445
}
446
 
447
/*
448
 *----------------------------------------------------------------------
449
 *
450
 * TclStat --
451
 *
452
 *      This procedure replaces the library version of stat and lsat.
453
 *      The chain of functions that have been "inserted" into the
454
 *      'statProcList' will be called in succession until either
455
 *      a value of zero is returned, or the entire list is visited.
456
 *
457
 * Results:
458
 *      See stat documentation.
459
 *
460
 * Side effects:
461
 *      See stat documentation.
462
 *
463
 *----------------------------------------------------------------------
464
 */
465
 
466
int
467
TclStat(path, buf)
468
    CONST char *path;           /* Path of file to stat (in current CP). */
469
    TclStat_ *buf;              /* Filled with results of stat call. */
470
{
471
    StatProc *statProcPtr = statProcList;
472
    int retVal = -1;
473
 
474
    /*
475
     * Call each of the "stat" function in succession.  A non-return
476
     * value of -1 indicates the particular function has succeeded.
477
     */
478
 
479
    while ((retVal == -1) && (statProcPtr != NULL)) {
480
        retVal = (*statProcPtr->proc)(path, buf);
481
        statProcPtr = statProcPtr->nextPtr;
482
    }
483
 
484
    return (retVal);
485
}
486
 
487
/*
488
 *----------------------------------------------------------------------
489
 *
490
 * TclAccess --
491
 *
492
 *      This procedure replaces the library version of access.
493
 *      The chain of functions that have been "inserted" into the
494
 *      'accessProcList' will be called in succession until either
495
 *      a value of zero is returned, or the entire list is visited.
496
 *
497
 * Results:
498
 *      See access documentation.
499
 *
500
 * Side effects:
501
 *      See access documentation.
502
 *
503
 *----------------------------------------------------------------------
504
 */
505
 
506
int
507
TclAccess(path, mode)
508
    CONST char *path;           /* Path of file to access (in current CP). */
509
    int mode;                   /* Permission setting. */
510
{
511
    AccessProc *accessProcPtr = accessProcList;
512
    int retVal = -1;
513
 
514
    /*
515
     * Call each of the "access" function in succession.  A non-return
516
     * value of -1 indicates the particular function has succeeded.
517
     */
518
 
519
    while ((retVal == -1) && (accessProcPtr != NULL)) {
520
        retVal = (*accessProcPtr->proc)(path, mode);
521
        accessProcPtr = accessProcPtr->nextPtr;
522
    }
523
 
524
    return (retVal);
525
}
526
 
527
/*
528
 *----------------------------------------------------------------------
529
 *
530
 * Tcl_OpenFileChannel --
531
 *
532
 *      The chain of functions that have been "inserted" into the
533
 *      'openFileChannelProcList' will be called in succession until
534
 *      either a valid file channel is returned, or the entire list is
535
 *      visited.
536
 *
537
 * Results:
538
 *      The new channel or NULL, if the named file could not be opened.
539
 *
540
 * Side effects:
541
 *      May open the channel and may cause creation of a file on the
542
 *      file system.
543
 *
544
 *----------------------------------------------------------------------
545
 */
546
 
547
Tcl_Channel
548
Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
549
    Tcl_Interp *interp;                 /* Interpreter for error reporting;
550
                                         * can be NULL. */
551
    char *fileName;                     /* Name of file to open. */
552
    char *modeString;                   /* A list of POSIX open modes or
553
                                         * a string such as "rw". */
554
    int permissions;                    /* If the open involves creating a
555
                                         * file, with what modes to create
556
                                         * it? */
557
{
558
    OpenFileChannelProc *openFileChannelProcPtr = openFileChannelProcList;
559
    Tcl_Channel retVal = NULL;
560
 
561
    /*
562
     * Call each of the "Tcl_OpenFileChannel" function in succession.
563
     * A non-NULL return value indicates the particular function has
564
     * succeeded.
565
     */
566
 
567
    while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
568
        retVal = (*openFileChannelProcPtr->proc)(interp, fileName,
569
                modeString, permissions);
570
        openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
571
    }
572
 
573
    return (retVal);
574
}
575
 
576
/*
577
 *----------------------------------------------------------------------
578
 *
579
 * TclStatInsertProc --
580
 *
581
 *      Insert the passed procedure pointer at the head of the list of
582
 *      functions which are used during a call to 'TclStat(...)'. The
583
 *      passed function should be have exactly like 'TclStat' when called
584
 *      during that time (see 'TclStat(...)' for more informatin).
585
 *      The function will be added even if it already in the list.
586
 *
587
 * Results:
588
 *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list
589
 *      could not be allocated.
590
 *
591
 * Side effects:
592
 *      Memory allocataed and modifies the link list for 'TclStat'
593
 *      functions.
594
 *
595
 *----------------------------------------------------------------------
596
 */
597
 
598
int
599
TclStatInsertProc (proc)
600
    TclStatProc_ *proc;
601
{
602
    int retVal = TCL_ERROR;
603
 
604
    if (proc != NULL) {
605
        StatProc *newStatProcPtr;
606
 
607
        newStatProcPtr = (StatProc *)Tcl_Alloc(sizeof(StatProc));;
608
 
609
        if (newStatProcPtr != NULL) {
610
            newStatProcPtr->proc = proc;
611
            newStatProcPtr->nextPtr = statProcList;
612
            statProcList = newStatProcPtr;
613
 
614
            retVal = TCL_OK;
615
        }
616
    }
617
 
618
    return (retVal);
619
}
620
 
621
/*
622
 *----------------------------------------------------------------------
623
 *
624
 * TclStatDeleteProc --
625
 *
626
 *      Removed the passed function pointer from the list of 'TclStat'
627
 *      functions.  Ensures that the built-in stat function is not
628
 *      removvable.
629
 *
630
 * Results:
631
 *      TCL_OK if the procedure pointer was successfully removed,
632
 *      TCL_ERROR otherwise.
633
 *
634
 * Side effects:
635
 *      Memory is deallocated and the respective list updated.
636
 *
637
 *----------------------------------------------------------------------
638
 */
639
 
640
int
641
TclStatDeleteProc (proc)
642
    TclStatProc_ *proc;
643
{
644
    int retVal = TCL_ERROR;
645
    StatProc *tmpStatProcPtr = statProcList;
646
    StatProc *prevStatProcPtr = NULL;
647
 
648
    /*
649
     * Traverse the 'statProcList' looking for the particular node
650
     * whose 'proc' member matches 'proc' and remove that one from
651
     * the list.  Ensure that the "default" node cannot be removed.
652
     */
653
 
654
    while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) {
655
        if (tmpStatProcPtr->proc == proc) {
656
            if (prevStatProcPtr == NULL) {
657
                statProcList = tmpStatProcPtr->nextPtr;
658
            } else {
659
                prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr;
660
            }
661
 
662
            Tcl_Free((char *)tmpStatProcPtr);
663
 
664
            retVal = TCL_OK;
665
        } else {
666
            prevStatProcPtr = tmpStatProcPtr;
667
            tmpStatProcPtr = tmpStatProcPtr->nextPtr;
668
        }
669
    }
670
 
671
    return (retVal);
672
}
673
 
674
/*
675
 *----------------------------------------------------------------------
676
 *
677
 * TclAccessInsertProc --
678
 *
679
 *      Insert the passed procedure pointer at the head of the list of
680
 *      functions which are used during a call to 'TclAccess(...)'. The
681
 *      passed function should be have exactly like 'TclAccess' when
682
 *      called during that time (see 'TclAccess(...)' for more informatin).
683
 *      The function will be added even if it already in the list.
684
 *
685
 * Results:
686
 *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list
687
 *      could not be allocated.
688
 *
689
 * Side effects:
690
 *      Memory allocataed and modifies the link list for 'TclAccess'
691
 *      functions.
692
 *
693
 *----------------------------------------------------------------------
694
 */
695
 
696
int
697
TclAccessInsertProc(proc)
698
    TclAccessProc_ *proc;
699
{
700
    int retVal = TCL_ERROR;
701
 
702
    if (proc != NULL) {
703
        AccessProc *newAccessProcPtr;
704
 
705
        newAccessProcPtr = (AccessProc *)Tcl_Alloc(sizeof(AccessProc));;
706
 
707
        if (newAccessProcPtr != NULL) {
708
            newAccessProcPtr->proc = proc;
709
            newAccessProcPtr->nextPtr = accessProcList;
710
            accessProcList = newAccessProcPtr;
711
 
712
            retVal = TCL_OK;
713
        }
714
    }
715
 
716
    return (retVal);
717
}
718
 
719
/*
720
 *----------------------------------------------------------------------
721
 *
722
 * TclAccessDeleteProc --
723
 *
724
 *      Removed the passed function pointer from the list of 'TclAccess'
725
 *      functions.  Ensures that the built-in access function is not
726
 *      removvable.
727
 *
728
 * Results:
729
 *      TCL_OK if the procedure pointer was successfully removed,
730
 *      TCL_ERROR otherwise.
731
 *
732
 * Side effects:
733
 *      Memory is deallocated and the respective list updated.
734
 *
735
 *----------------------------------------------------------------------
736
 */
737
 
738
int
739
TclAccessDeleteProc(proc)
740
    TclAccessProc_ *proc;
741
{
742
    int retVal = TCL_ERROR;
743
    AccessProc *tmpAccessProcPtr = accessProcList;
744
    AccessProc *prevAccessProcPtr = NULL;
745
 
746
    /*
747
     * Traverse the 'accessProcList' looking for the particular node
748
     * whose 'proc' member matches 'proc' and remove that one from
749
     * the list.  Ensure that the "default" node cannot be removed.
750
     */
751
 
752
    while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) {
753
        if (tmpAccessProcPtr->proc == proc) {
754
            if (prevAccessProcPtr == NULL) {
755
                accessProcList = tmpAccessProcPtr->nextPtr;
756
            } else {
757
                prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr;
758
            }
759
 
760
            Tcl_Free((char *)tmpAccessProcPtr);
761
 
762
            retVal = TCL_OK;
763
        } else {
764
            prevAccessProcPtr = tmpAccessProcPtr;
765
            tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
766
        }
767
    }
768
 
769
    return (retVal);
770
}
771
 
772
/*
773
 *----------------------------------------------------------------------
774
 *
775
 * TclOpenFileChannelInsertProc --
776
 *
777
 *      Insert the passed procedure pointer at the head of the list of
778
 *      functions which are used during a call to
779
 *      'Tcl_OpenFileChannel(...)'. The passed function should be have
780
 *      exactly like 'Tcl_OpenFileChannel' when called during that time
781
 *      (see 'Tcl_OpenFileChannel(...)' for more informatin). The
782
 *      function will be added even if it already in the list.
783
 *
784
 * Results:
785
 *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list
786
 *      could not be allocated.
787
 *
788
 * Side effects:
789
 *      Memory allocataed and modifies the link list for
790
 *      'Tcl_OpenFileChannel' functions.
791
 *
792
 *----------------------------------------------------------------------
793
 */
794
 
795
int
796
TclOpenFileChannelInsertProc(proc)
797
    TclOpenFileChannelProc_ *proc;
798
{
799
    int retVal = TCL_ERROR;
800
 
801
    if (proc != NULL) {
802
        OpenFileChannelProc *newOpenFileChannelProcPtr;
803
 
804
        newOpenFileChannelProcPtr =
805
                (OpenFileChannelProc *)Tcl_Alloc(sizeof(OpenFileChannelProc));;
806
 
807
        if (newOpenFileChannelProcPtr != NULL) {
808
            newOpenFileChannelProcPtr->proc = proc;
809
            newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
810
            openFileChannelProcList = newOpenFileChannelProcPtr;
811
 
812
            retVal = TCL_OK;
813
        }
814
    }
815
 
816
    return (retVal);
817
}
818
 
819
/*
820
 *----------------------------------------------------------------------
821
 *
822
 * TclOpenFileChannelDeleteProc --
823
 *
824
 *      Removed the passed function pointer from the list of
825
 *      'Tcl_OpenFileChannel' functions.  Ensures that the built-in
826
 *      open file channel function is not removvable.
827
 *
828
 * Results:
829
 *      TCL_OK if the procedure pointer was successfully removed,
830
 *      TCL_ERROR otherwise.
831
 *
832
 * Side effects:
833
 *      Memory is deallocated and the respective list updated.
834
 *
835
 *----------------------------------------------------------------------
836
 */
837
 
838
int
839
TclOpenFileChannelDeleteProc(proc)
840
    TclOpenFileChannelProc_ *proc;
841
{
842
    int retVal = TCL_ERROR;
843
    OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
844
    OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;
845
 
846
    /*
847
     * Traverse the 'openFileChannelProcList' looking for the particular
848
     * node whose 'proc' member matches 'proc' and remove that one from
849
     * the list.  Ensure that the "default" node cannot be removed.
850
     */
851
 
852
    while ((retVal == TCL_ERROR) &&
853
            (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) {
854
        if (tmpOpenFileChannelProcPtr->proc == proc) {
855
            if (prevOpenFileChannelProcPtr == NULL) {
856
                openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
857
            } else {
858
                prevOpenFileChannelProcPtr->nextPtr =
859
                        tmpOpenFileChannelProcPtr->nextPtr;
860
            }
861
 
862
            Tcl_Free((char *)tmpOpenFileChannelProcPtr);
863
 
864
            retVal = TCL_OK;
865
        } else {
866
            prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
867
            tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
868
        }
869
    }
870
 
871
    return (retVal);
872
}

powered by: WebSVN 2.1.0

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