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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25