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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 71 - (show annotations) (download)
Sat Nov 5 11:07:06 2016 UTC (8 years, 1 month ago) by dashley
File MIME type: text/plain
File size: 24709 byte(s)
Set EOL properties appropriately to facilitate simultaneous Linux and Windows development.
1 /* $Header$ */
2 /*
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 /* End of tclioutil.c */

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25