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

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclioutil.c

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25