/[dtapublic]/to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclioutil.c
ViewVC logotype

Contents of /to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclioutil.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 29 - (show annotations) (download)
Sat Oct 8 07:08:47 2016 UTC (7 years, 5 months ago) by dashley
File MIME type: text/plain
File size: 25917 byte(s)
Directories relocated.
1 /* $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