aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/generic
diff options
context:
space:
mode:
authorPoul-Henning Kamp <phk@FreeBSD.org>1996-09-18 14:12:34 +0000
committerPoul-Henning Kamp <phk@FreeBSD.org>1996-09-18 14:12:34 +0000
commit8569730d6bc2e4cb5e784997313325b13518e066 (patch)
tree6030c8489bce8cf7333fc4d0b644065e106224b5 /contrib/tcl/generic
parent403acdc0da2969f284b74b720692585bfc676190 (diff)
downloadsrc-8569730d6bc2e4cb5e784997313325b13518e066.tar.gz
src-8569730d6bc2e4cb5e784997313325b13518e066.zip
Import tcl7.5p1
Notes
Notes: svn path=/vendor/tcl/dist/; revision=18351
Diffstat (limited to 'contrib/tcl/generic')
-rw-r--r--contrib/tcl/generic/patchlevel.h4
-rw-r--r--contrib/tcl/generic/tcl.h52
-rw-r--r--contrib/tcl/generic/tclBasic.c28
-rw-r--r--contrib/tcl/generic/tclCkalloc.c88
-rw-r--r--contrib/tcl/generic/tclClock.c36
-rw-r--r--contrib/tcl/generic/tclCmdAH.c33
-rw-r--r--contrib/tcl/generic/tclCmdIL.c14
-rw-r--r--contrib/tcl/generic/tclCmdMZ.c6
-rw-r--r--contrib/tcl/generic/tclDate.c20
-rw-r--r--contrib/tcl/generic/tclEnv.c22
-rw-r--r--contrib/tcl/generic/tclEvent.c16
-rw-r--r--contrib/tcl/generic/tclFHandle.c37
-rw-r--r--contrib/tcl/generic/tclGetDate.y22
-rw-r--r--contrib/tcl/generic/tclIO.c348
-rw-r--r--contrib/tcl/generic/tclIOCmd.c2
-rw-r--r--contrib/tcl/generic/tclIOUtil.c6
-rw-r--r--contrib/tcl/generic/tclInt.h20
-rw-r--r--contrib/tcl/generic/tclInterp.c14
-rw-r--r--contrib/tcl/generic/tclLoad.c9
-rw-r--r--contrib/tcl/generic/tclPosixStr.c6
-rw-r--r--contrib/tcl/generic/tclPreserve.c6
-rw-r--r--contrib/tcl/generic/tclUtil.c5
22 files changed, 599 insertions, 195 deletions
diff --git a/contrib/tcl/generic/patchlevel.h b/contrib/tcl/generic/patchlevel.h
index 2482cd3ed882..c755edec4901 100644
--- a/contrib/tcl/generic/patchlevel.h
+++ b/contrib/tcl/generic/patchlevel.h
@@ -17,7 +17,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) patchlevel.h 1.17 96/04/08 14:15:07
+ * SCCS: @(#) patchlevel.h 1.18 96/07/17 14:17:33
*/
-#define TCL_PATCH_LEVEL "7.5"
+#define TCL_PATCH_LEVEL "7.5p1"
diff --git a/contrib/tcl/generic/tcl.h b/contrib/tcl/generic/tcl.h
index b37665f94688..37490ba231cc 100644
--- a/contrib/tcl/generic/tcl.h
+++ b/contrib/tcl/generic/tcl.h
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tcl.h 1.266 96/04/10 11:25:19
+ * SCCS: @(#) tcl.h 1.269 96/06/13 16:36:48
*/
#ifndef _TCL
@@ -21,16 +21,26 @@
* compilers. We use this method because there is no autoconf equivalent.
*/
-#if defined(_WIN32) && !defined(__WIN32__)
-# define __WIN32__
+#ifndef __WIN32__
+# if defined(_WIN32) || defined(WIN32)
+# define __WIN32__
+# endif
#endif
#ifdef __WIN32__
-# undef USE_PROTOTYPE
-# undef HAS_STDARG
-# define USE_PROTOTYPE
-# define HAS_STDARG
-#endif
+# ifndef USE_PROTOTYPE
+# define USE_PROTOTYPE 1
+# endif
+# ifndef HAS_STDARG
+# define HAS_STDARG 1
+# endif
+# ifndef USE_PROTOTYPE
+# define USE_PROTOTYPE 1
+# endif
+# ifndef USE_TCLALLOC
+# define USE_TCLALLOC 1
+# endif
+#endif /* __WIN32__ */
#ifndef BUFSIZ
#include <stdio.h>
@@ -343,8 +353,16 @@ typedef struct Tcl_DString {
* of debugging hooks defined in tclCkalloc.c.
*/
+EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size));
+EXTERN void Tcl_Free _ANSI_ARGS_((char *ptr));
+EXTERN char * Tcl_Realloc _ANSI_ARGS_((char *ptr,
+ unsigned int size));
+
#ifdef TCL_MEM_DEBUG
+# define Tcl_Alloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
+# define Tcl_Free(x) Tcl_DbCkfree(x, __FILE__, __LINE__)
+# define Tcl_Realloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__)
# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
@@ -355,10 +373,15 @@ EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file,
#else
-# define ckalloc(x) malloc(x)
-# define ckfree(x) free(x)
-# define ckrealloc(x,y) realloc(x,y)
-
+# if USE_TCLALLOC
+# define ckalloc(x) Tcl_Alloc(x)
+# define ckfree(x) Tcl_Free(x)
+# define ckrealloc(x,y) Tcl_Realloc(x,y)
+# else
+# define ckalloc(x) malloc(x)
+# define ckfree(x) free(x)
+# define ckrealloc(x,y) realloc(x,y)
+# endif
# define Tcl_DumpActiveMemory(x)
# define Tcl_ValidateAllMemory(x,y)
@@ -695,8 +718,9 @@ EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp *interp,
ClientData clientData));
EXTERN void Tcl_CancelIdleCall _ANSI_ARGS_((Tcl_IdleProc *idleProc,
ClientData clientData));
-EXTERN VOID * Tcl_Ckalloc _ANSI_ARGS_((unsigned int size));
-EXTERN void Tcl_Ckfree _ANSI_ARGS_((char *ptr));
+#define Tcl_Ckalloc Tcl_Alloc
+#define Tcl_Ckfree Tcl_Free
+#define Tcl_Ckrealloc Tcl_Realloc
EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char *cmd));
diff --git a/contrib/tcl/generic/tclBasic.c b/contrib/tcl/generic/tclBasic.c
index e081402186c9..7f39f80c12e0 100644
--- a/contrib/tcl/generic/tclBasic.c
+++ b/contrib/tcl/generic/tclBasic.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclBasic.c 1.210 96/03/25 17:17:54
+ * SCCS: @(#) tclBasic.c 1.211 96/05/10 17:48:04
*/
#include "tclInt.h"
@@ -21,6 +21,16 @@
#include "patchlevel.h"
/*
+ * This variable indicates to the close procedures of channel drivers that
+ * we are in the middle of an interpreter deletion, and hence in "implicit"
+ * close mode. In that mode, the close procedures should not close the
+ * OS handle for standard IO channels. Since interpreter deletion may be
+ * recursive, this variable is actually a counter of the levels of nesting.
+ */
+
+int tclInInterpreterDeletion = 0;
+
+/*
* Static procedures in this file:
*/
@@ -570,6 +580,13 @@ DeleteInterpProc(interp)
}
/*
+ * Increment the interp deletion counter, so that close procedures
+ * for channel drivers can notice that we are in "implicit" close mode.
+ */
+
+ tclInInterpreterDeletion++;
+
+ /*
* First delete all the commands. There's a special hack here
* because "tkerror" is just a synonym for "bgerror" (they share
* a Command structure). Just delete the hash table entry for
@@ -676,6 +693,15 @@ DeleteInterpProc(interp)
iPtr->tracePtr = nextPtr;
}
+ /*
+ * Finally decrement the nested interpreter deletion counter.
+ */
+
+ tclInInterpreterDeletion--;
+ if (tclInInterpreterDeletion < 0) {
+ tclInInterpreterDeletion = 0;
+ }
+
ckfree((char *) iPtr);
}
diff --git a/contrib/tcl/generic/tclCkalloc.c b/contrib/tcl/generic/tclCkalloc.c
index e8f3b37ff426..62744a612fdc 100644
--- a/contrib/tcl/generic/tclCkalloc.c
+++ b/contrib/tcl/generic/tclCkalloc.c
@@ -13,7 +13,7 @@
* This code contributed by Karl Lehenbauer and Mark Diekhans
*
*
- * SCCS: @(#) tclCkalloc.c 1.17 96/03/14 13:05:56
+ * SCCS: @(#) tclCkalloc.c 1.20 96/06/06 13:48:27
*/
#include "tclInt.h"
@@ -471,6 +471,50 @@ Tcl_DbCkrealloc(ptr, size, file, line)
Tcl_DbCkfree(ptr, file, line);
return(new);
}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Alloc, et al. --
+ *
+ * These functions are defined in terms of the debugging versions
+ * when TCL_MEM_DEBUG is set.
+ *
+ * Results:
+ * Same as the debug versions.
+ *
+ * Side effects:
+ * Same as the debug versions.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_Alloc
+#undef Tcl_Free
+#undef Tcl_Realloc
+
+char *
+Tcl_Alloc(size)
+ unsigned int size;
+{
+ return Tcl_DbCkalloc(size, "unknown", 0);
+}
+
+void
+Tcl_Free(ptr)
+ char *ptr;
+{
+ Tcl_DbCkfree(ptr, "unknown", 0);
+}
+
+char *
+Tcl_Realloc(ptr, size)
+ char *ptr;
+ unsigned int size;
+{
+ return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
+}
/*
*----------------------------------------------------------------------
@@ -606,8 +650,8 @@ void
Tcl_InitMemory(interp)
Tcl_Interp *interp;
{
-Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,
- (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,
+ (Tcl_CmdDeleteProc *) NULL);
}
#else
@@ -616,14 +660,15 @@ Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,
/*
*----------------------------------------------------------------------
*
- * Tcl_Ckalloc --
+ * Tcl_Alloc --
* Interface to malloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
-VOID *
-Tcl_Ckalloc (size)
+
+char *
+Tcl_Alloc (size)
unsigned int size;
{
char *result;
@@ -633,7 +678,6 @@ Tcl_Ckalloc (size)
panic("unable to alloc %d bytes", size);
return result;
}
-
char *
Tcl_DbCkalloc(size, file, line)
@@ -653,6 +697,30 @@ Tcl_DbCkalloc(size, file, line)
return result;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Realloc --
+ * Interface to realloc when TCL_MEM_DEBUG is disabled. It does check
+ * that memory was actually allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_Realloc(ptr, size)
+ char *ptr;
+ unsigned int size;
+{
+ char *result;
+
+ result = realloc(ptr, size);
+ if (result == NULL)
+ panic("unable to realloc %d bytes", size);
+ return result;
+}
+
char *
Tcl_DbCkrealloc(ptr, size, file, line)
char *ptr;
@@ -671,18 +739,20 @@ Tcl_DbCkrealloc(ptr, size, file, line)
}
return result;
}
+
/*
*----------------------------------------------------------------------
*
- * TckCkfree --
+ * Tcl_Free --
* Interface to free when TCL_MEM_DEBUG is disabled. Done here rather
* in the macro to keep some modules from being compiled with
* TCL_MEM_DEBUG enabled and some with it disabled.
*
*----------------------------------------------------------------------
*/
+
void
-Tcl_Ckfree (ptr)
+Tcl_Free (ptr)
char *ptr;
{
free (ptr);
diff --git a/contrib/tcl/generic/tclClock.c b/contrib/tcl/generic/tclClock.c
index 3fb4abdd4504..3eaf99a16f2d 100644
--- a/contrib/tcl/generic/tclClock.c
+++ b/contrib/tcl/generic/tclClock.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclClock.c 1.19 96/03/13 11:28:45
+ * SCCS: @(#) tclClock.c 1.20 96/07/23 16:14:45
*/
#include "tcl.h"
@@ -71,7 +71,7 @@ Tcl_ClockCmd (dummy, interp, argc, argv)
argv[0], " clicks\"", (char *) NULL);
return TCL_ERROR;
}
- sprintf(interp->result, "%lu", TclGetClicks());
+ sprintf(interp->result, "%lu", TclpGetClicks());
return TCL_OK;
} else if ((c == 'f') && (strncmp(argv[1], "format", length) == 0)) {
char *format = "%a %b %d %X %Z %Y";
@@ -148,13 +148,13 @@ Tcl_ClockCmd (dummy, interp, argc, argv)
if (ParseTime(interp, baseStr, &baseClock) != TCL_OK)
return TCL_ERROR;
} else {
- baseClock = TclGetSeconds();
+ baseClock = TclpGetSeconds();
}
if (useGMT) {
zone = -50000; /* Force GMT */
} else {
- zone = TclGetTimeZone(baseClock);
+ zone = TclpGetTimeZone(baseClock);
}
if (TclGetDate(argv[2], baseClock, zone, &clockVal) < 0) {
@@ -171,7 +171,7 @@ Tcl_ClockCmd (dummy, interp, argc, argv)
argv[0], " seconds\"", (char *) NULL);
return TCL_ERROR;
}
- sprintf(interp->result, "%lu", TclGetSeconds());
+ sprintf(interp->result, "%lu", TclpGetSeconds());
return TCL_OK;
} else {
Tcl_AppendResult(interp, "unknown option \"", argv[1],
@@ -276,6 +276,7 @@ FormatClock(interp, clockVal, useGMT, format)
struct tm *timeDataPtr;
Tcl_DString buffer;
int bufSize;
+ char *p;
#ifdef TCL_USE_TIMEZONE_VAR
int savedTimeZone;
char *savedTZEnv;
@@ -315,23 +316,28 @@ FormatClock(interp, clockVal, useGMT, format)
}
#endif
- if (useGMT) {
- timeDataPtr = gmtime((time_t *) &clockVal);
- } else {
- timeDataPtr = localtime((time_t *) &clockVal);
- }
+ timeDataPtr = TclpGetDate((time_t *) &clockVal, useGMT);
/*
- * Format the time, increasing the buffer size until strftime succeeds.
+ * Make a guess at the upper limit on the substituted string size
+ * based on the number of percents in the string.
*/
- bufSize = TCL_DSTRING_STATIC_SIZE - 1;
+
+ for (bufSize = 0, p = format; *p != '\0'; p++) {
+ if (*p == '%') {
+ bufSize += 40;
+ } else {
+ bufSize++;
+ }
+ }
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, bufSize);
- while (strftime(buffer.string, (unsigned int) bufSize, format,
+ if (TclStrftime(buffer.string, (unsigned int) bufSize, format,
timeDataPtr) == 0) {
- bufSize *= 2;
- Tcl_DStringSetLength(&buffer, bufSize);
+ Tcl_DStringFree(&buffer);
+ Tcl_AppendResult(interp, "bad format string", (char *)NULL);
+ return TCL_ERROR;
}
#ifdef TCL_USE_TIMEZONE_VAR
diff --git a/contrib/tcl/generic/tclCmdAH.c b/contrib/tcl/generic/tclCmdAH.c
index 526a11181ac7..6b76d82b57b8 100644
--- a/contrib/tcl/generic/tclCmdAH.c
+++ b/contrib/tcl/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdAH.c 1.107 96/04/09 17:14:39
+ * SCCS: @(#) tclCmdAH.c 1.111 96/07/30 09:33:59
*/
#include "tclInt.h"
@@ -650,7 +650,30 @@ Tcl_FileCmd(dummy, interp, argc, argv)
goto not3Args;
}
- Tcl_SplitPath(argv[2], &pargc, &pargv);
+ fileName = argv[2];
+
+ /*
+ * If there is only one element, and it starts with a tilde,
+ * perform tilde substitution and resplit the path.
+ */
+
+ Tcl_SplitPath(fileName, &pargc, &pargv);
+ if ((pargc == 1) && (*fileName == '~')) {
+ ckfree((char*) pargv);
+ fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
+ if (fileName == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_SplitPath(fileName, &pargc, &pargv);
+ Tcl_DStringSetLength(&buffer, 0);
+ }
+
+ /*
+ * Return the last component, unless it is the only component, and it
+ * is the root of an absolute path.
+ */
+
if (pargc > 0) {
if ((pargc > 1)
|| (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
@@ -727,7 +750,7 @@ Tcl_FileCmd(dummy, interp, argc, argv)
Tcl_DStringResult(interp, &buffer);
goto done;
}
-
+
/*
* Next, handle operations that can be satisfied with the "access"
* kernel call.
@@ -1499,14 +1522,14 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
argIndex++;
format++;
}
- if (width > 1000) {
+ if (width > 100000) {
/*
* Don't allow arbitrarily large widths: could cause core
* dump when we try to allocate a zillion bytes of memory
* below.
*/
- width = 1000;
+ width = 100000;
} else if (width < 0) {
width = 0;
}
diff --git a/contrib/tcl/generic/tclCmdIL.c b/contrib/tcl/generic/tclCmdIL.c
index 9998e19a97ee..0a3b25a98c81 100644
--- a/contrib/tcl/generic/tclCmdIL.c
+++ b/contrib/tcl/generic/tclCmdIL.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdIL.c 1.119 96/03/22 12:10:14
+ * SCCS: @(#) tclCmdIL.c 1.120 96/07/10 17:16:03
*/
#include "tclInt.h"
@@ -1041,7 +1041,8 @@ Tcl_LrangeCmd(notUsed, interp, argc, argv)
* Chop off trailing spaces.
*/
- while (isspace(UCHAR(end[-1]))) {
+ while ((end != begin) && (isspace(UCHAR(end[-1])))
+ && (((end-1) == begin) || (end[-2] != '\\'))) {
end--;
}
c = *end;
@@ -1146,11 +1147,14 @@ Tcl_LreplaceCmd(notUsed, interp, argc, argv)
}
/*
- * Add the elements before "first" to the result. Drop any terminating
- * white space, since a separator will be added below, if needed.
+ * Add the elements before "first" to the result. Remove any
+ * trailing white space, to make the result look as clean as
+ * possible (this matters primarily if the replacement string is
+ * empty).
*/
- while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1])))) {
+ while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1])))
+ && (((p1-1) == argv[1]) || (p1[-2] != '\\'))) {
p1--;
}
savedChar = *p1;
diff --git a/contrib/tcl/generic/tclCmdMZ.c b/contrib/tcl/generic/tclCmdMZ.c
index faf9eed47b65..5158ddeea77e 100644
--- a/contrib/tcl/generic/tclCmdMZ.c
+++ b/contrib/tcl/generic/tclCmdMZ.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdMZ.c 1.65 96/02/09 14:59:52
+ * SCCS: @(#) tclCmdMZ.c 1.66 96/07/23 16:15:55
*/
#include "tclInt.h"
@@ -1748,7 +1748,7 @@ Tcl_TimeCmd(dummy, interp, argc, argv)
" command ?count?\"", (char *) NULL);
return TCL_ERROR;
}
- TclGetTime(&start);
+ TclpGetTime(&start);
for (i = count ; i > 0; i--) {
result = Tcl_Eval(interp, argv[1]);
if (result != TCL_OK) {
@@ -1761,7 +1761,7 @@ Tcl_TimeCmd(dummy, interp, argc, argv)
return result;
}
}
- TclGetTime(&stop);
+ TclpGetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
Tcl_ResetResult(interp);
sprintf(interp->result, "%.0f microseconds per iteration",
diff --git a/contrib/tcl/generic/tclDate.c b/contrib/tcl/generic/tclDate.c
index b39d817e9eaa..abcafcb0ed75 100644
--- a/contrib/tcl/generic/tclDate.c
+++ b/contrib/tcl/generic/tclDate.c
@@ -1,8 +1,8 @@
/*
- * tclGetdate.c --
+ * tclDate.c --
*
* This file is generated from a yacc grammar defined in
- * the file tclGetdate.y
+ * the file tclGetDate.y
*
* Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
* Copyright (c) 1995-1996 Sun Microsystems, Inc.
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * @(#) tclDate.c 1.24 96/04/18 16:53:56
+ * @(#) tclDate.c 1.25 96/07/23 16:10:50
*/
#include "tclInt.h"
@@ -24,8 +24,6 @@
# define EPOCH 1970
# define START_OF_TIME 1902
# define END_OF_TIME 2037
-
-extern struct tm *localtime();
#endif
#define HOUR(x) ((int) (60 * x))
@@ -463,7 +461,7 @@ Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr)
return -1;
Julian += tod;
if (DSTmode == DSTon
- || (DSTmode == DSTmaybe && localtime(&Julian)->tm_isdst))
+ || (DSTmode == DSTmaybe && TclpGetDate(&Julian, 0)->tm_isdst))
Julian -= 60 * 60;
*TimePtr = Julian;
return 0;
@@ -478,8 +476,8 @@ DSTcorrect(Start, Future)
time_t StartDay;
time_t FutureDay;
- StartDay = (localtime(&Start)->tm_hour + 1) % 24;
- FutureDay = (localtime(&Future)->tm_hour + 1) % 24;
+ StartDay = (TclpGetDate(&Start, 0)->tm_hour + 1) % 24;
+ FutureDay = (TclpGetDate(&Future, 0)->tm_hour + 1) % 24;
return (Future - Start) + (StartDay - FutureDay) * 60L * 60L;
}
@@ -494,7 +492,7 @@ RelativeDate(Start, DayOrdinal, DayNumber)
time_t now;
now = Start;
- tm = localtime(&now);
+ tm = TclpGetDate(&now, 0);
now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7);
now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1);
return DSTcorrect(Start, now);
@@ -516,7 +514,7 @@ RelativeMonth(Start, RelMonth, TimePtr)
*TimePtr = 0;
return 0;
}
- tm = localtime(&Start);
+ tm = TclpGetDate(&Start, 0);
Month = 12 * tm->tm_year + tm->tm_mon + RelMonth;
Year = Month / 12;
Month = Month % 12 + 1;
@@ -728,7 +726,7 @@ TclGetDate(p, now, zone, timePtr)
time_t tod;
TclDateInput = p;
- tm = localtime((time_t *) &now);
+ tm = TclpGetDate((time_t *) &now, 0);
TclDateYear = tm->tm_year;
TclDateMonth = tm->tm_mon + 1;
TclDateDay = tm->tm_mday;
diff --git a/contrib/tcl/generic/tclEnv.c b/contrib/tcl/generic/tclEnv.c
index 4b92cc29c55a..cfffefe21f77 100644
--- a/contrib/tcl/generic/tclEnv.c
+++ b/contrib/tcl/generic/tclEnv.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclEnv.c 1.34 96/04/15 18:18:36
+ * SCCS: @(#) tclEnv.c 1.37 96/07/23 16:28:26
*/
/*
@@ -211,12 +211,17 @@ TclGetEnv(name)
char *name; /* Name of desired environment variable. */
{
int i;
- size_t len;
+ size_t len, nameLen;
+ char *equal;
+ nameLen = strlen(name);
for (i = 0; environ[i] != NULL; i++) {
- len = (size_t) ((char *) strchr(environ[i], '=') - environ[i]);
- if ((len > 0 && !strncmp(name, environ[i], len))
- || (*name == '\0')) {
+ equal = strchr(environ[i], '=');
+ if (equal == NULL) {
+ continue;
+ }
+ len = (size_t) (equal - environ[i]);
+ if ((len == nameLen) && (strncmp(name, environ[i], len) == 0)) {
/*
* The caller of this function should regard this
* as static memory.
@@ -601,4 +606,11 @@ EnvExitProc(clientData)
ckfree(*p);
}
ckfree((char *) environ);
+
+ /*
+ * Note that we need to reset the environ global so the Borland C run-time
+ * doesn't choke on exit.
+ */
+
+ environ = NULL;
}
diff --git a/contrib/tcl/generic/tclEvent.c b/contrib/tcl/generic/tclEvent.c
index 3c9f7d249ef1..7a081c714bc9 100644
--- a/contrib/tcl/generic/tclEvent.c
+++ b/contrib/tcl/generic/tclEvent.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclEvent.c 1.127 96/03/22 12:12:33
+ * SCCS: @(#) tclEvent.c 1.128 96/07/23 16:12:34
*/
#include "tclInt.h"
@@ -633,7 +633,7 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData)
* Compute when the event should fire.
*/
- TclGetTime(&timerHandlerPtr->time);
+ TclpGetTime(&timerHandlerPtr->time);
timerHandlerPtr->time.sec += milliseconds/1000;
timerHandlerPtr->time.usec += (milliseconds%1000)*1000;
if (timerHandlerPtr->time.usec >= 1000000) {
@@ -755,7 +755,7 @@ Tcl_CreateModalTimeout(milliseconds, proc, clientData)
* of the handler.
*/
- TclGetTime(&timerHandlerPtr->time);
+ TclpGetTime(&timerHandlerPtr->time);
timerHandlerPtr->time.sec += milliseconds/1000;
timerHandlerPtr->time.usec += (milliseconds%1000)*1000;
if (timerHandlerPtr->time.usec >= 1000000) {
@@ -860,7 +860,7 @@ TimerHandlerSetupProc(clientData, flags)
return;
}
- TclGetTime(&blockTime);
+ TclpGetTime(&blockTime);
blockTime.sec = timerHandlerPtr->time.sec - blockTime.sec;
blockTime.usec = timerHandlerPtr->time.usec - blockTime.usec;
if (blockTime.usec < 0) {
@@ -910,7 +910,7 @@ TimerHandlerCheckProc(clientData, flags)
gotTime = 0;
timerHandlerPtr = firstTimerHandlerPtr;
if ((flags & TCL_TIMER_EVENTS) && (timerHandlerPtr != NULL)) {
- TclGetTime(&curTime);
+ TclpGetTime(&curTime);
gotTime = 1;
if ((timerHandlerPtr->time.sec < curTime.sec)
|| ((timerHandlerPtr->time.sec == curTime.sec)
@@ -921,7 +921,7 @@ TimerHandlerCheckProc(clientData, flags)
timerHandlerPtr = firstModalHandlerPtr;
if (timerHandlerPtr != NULL) {
if (!gotTime) {
- TclGetTime(&curTime);
+ TclpGetTime(&curTime);
}
if ((timerHandlerPtr->time.sec < curTime.sec)
|| ((timerHandlerPtr->time.sec == curTime.sec)
@@ -2134,7 +2134,7 @@ TclWaitForFile(file, mask, timeout)
*/
if (timeout > 0) {
- TclGetTime(&now);
+ TclpGetTime(&now);
abortTime.sec = now.sec + timeout/1000;
abortTime.usec = now.usec + (timeout%1000)*1000;
if (abortTime.usec >= 1000000) {
@@ -2176,7 +2176,7 @@ TclWaitForFile(file, mask, timeout)
if (timeout == 0) {
break;
}
- TclGetTime(&now);
+ TclpGetTime(&now);
if ((abortTime.sec < now.sec)
|| ((abortTime.sec == now.sec)
&& (abortTime.usec <= now.usec))) {
diff --git a/contrib/tcl/generic/tclFHandle.c b/contrib/tcl/generic/tclFHandle.c
index 19875c5c4773..f8b3798b3e70 100644
--- a/contrib/tcl/generic/tclFHandle.c
+++ b/contrib/tcl/generic/tclFHandle.c
@@ -8,10 +8,11 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclFHandle.c 1.6 96/02/13 16:29:55
+ * SCCS: @(#) tclFHandle.c 1.8 96/06/27 15:31:34
*/
#include "tcl.h"
+#include "tclInt.h"
#include "tclPort.h"
/*
@@ -112,7 +113,7 @@ Tcl_FreeFile(handle)
{
Tcl_HashEntry *entryPtr;
FileHandle *handlePtr = (FileHandle *) handle;
-
+
/*
* Invoke free procedure, then delete the handle.
*/
@@ -121,11 +122,24 @@ Tcl_FreeFile(handle)
(*handlePtr->proc)(handlePtr->data);
}
- entryPtr = Tcl_FindHashEntry(&fileTable, (char *) &handlePtr->key);
- if (entryPtr) {
- Tcl_DeleteHashEntry(entryPtr);
- ckfree((char *) handlePtr);
+ /*
+ * Tcl_File structures may be freed as a result of running the
+ * channel table exit handler. The file table is freed by the file
+ * table exit handler, which may run before the channel table exit
+ * handler. The file table exit handler sets the "initialized"
+ * variable back to zero, so that the Tcl_FreeFile (when invoked
+ * from the channel table exit handler) can notice that the file
+ * table has already been destroyed. Otherwise, accessing a
+ * deleted hash table would cause a panic.
+ */
+
+ if (initialized) {
+ entryPtr = Tcl_FindHashEntry(&fileTable, (char *) &handlePtr->key);
+ if (entryPtr) {
+ Tcl_DeleteHashEntry(entryPtr);
+ }
}
+ ckfree((char *) handlePtr);
}
/*
@@ -240,15 +254,6 @@ static void
FileExitProc(clientData)
ClientData clientData; /* Not used. */
{
- Tcl_HashSearch search;
- Tcl_HashEntry *entryPtr;
-
- entryPtr = Tcl_FirstHashEntry(&fileTable, &search);
-
- while (entryPtr) {
- ckfree(Tcl_GetHashValue(entryPtr));
- entryPtr = Tcl_NextHashEntry(&search);
- }
-
Tcl_DeleteHashTable(&fileTable);
+ initialized = 0;
}
diff --git a/contrib/tcl/generic/tclGetDate.y b/contrib/tcl/generic/tclGetDate.y
index 89a678e168e6..ee3da896e5f8 100644
--- a/contrib/tcl/generic/tclGetDate.y
+++ b/contrib/tcl/generic/tclGetDate.y
@@ -1,5 +1,5 @@
/*
- * tclGetdate.y --
+ * tclGetDate.y --
*
* Contains yacc grammar for parsing date and time strings
* based on getdate.y.
@@ -10,15 +10,15 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclGetDate.y 1.25 96/02/15 20:04:06
+ * SCCS: @(#) tclGetDate.y 1.26 96/07/23 16:09:45
*/
%{
/*
- * tclGetdate.c --
+ * tclDate.c --
*
* This file is generated from a yacc grammar defined in
- * the file tclGetdate.y
+ * the file tclGetDate.y
*
* Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
* Copyright (c) 1995-1996 Sun Microsystems, Inc.
@@ -40,8 +40,6 @@
# define EPOCH 1970
# define START_OF_TIME 1902
# define END_OF_TIME 2037
-
-extern struct tm *localtime();
#endif
#define HOUR(x) ((int) (60 * x))
@@ -617,7 +615,7 @@ Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr)
return -1;
Julian += tod;
if (DSTmode == DSTon
- || (DSTmode == DSTmaybe && localtime(&Julian)->tm_isdst))
+ || (DSTmode == DSTmaybe && TclpGetDate(&Julian, 0)->tm_isdst))
Julian -= 60 * 60;
*TimePtr = Julian;
return 0;
@@ -632,8 +630,8 @@ DSTcorrect(Start, Future)
time_t StartDay;
time_t FutureDay;
- StartDay = (localtime(&Start)->tm_hour + 1) % 24;
- FutureDay = (localtime(&Future)->tm_hour + 1) % 24;
+ StartDay = (TclpGetDate(&Start, 0)->tm_hour + 1) % 24;
+ FutureDay = (TclpGetDate(&Future, 0)->tm_hour + 1) % 24;
return (Future - Start) + (StartDay - FutureDay) * 60L * 60L;
}
@@ -648,7 +646,7 @@ RelativeDate(Start, DayOrdinal, DayNumber)
time_t now;
now = Start;
- tm = localtime(&now);
+ tm = TclpGetDate(&now, 0);
now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7);
now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1);
return DSTcorrect(Start, now);
@@ -670,7 +668,7 @@ RelativeMonth(Start, RelMonth, TimePtr)
*TimePtr = 0;
return 0;
}
- tm = localtime(&Start);
+ tm = TclpGetDate(&Start, 0);
Month = 12 * tm->tm_year + tm->tm_mon + RelMonth;
Year = Month / 12;
Month = Month % 12 + 1;
@@ -882,7 +880,7 @@ TclGetDate(p, now, zone, timePtr)
time_t tod;
yyInput = p;
- tm = localtime((time_t *) &now);
+ tm = TclpGetDate((time_t *) &now, 0);
yyYear = tm->tm_year;
yyMonth = tm->tm_mon + 1;
yyDay = tm->tm_mday;
diff --git a/contrib/tcl/generic/tclIO.c b/contrib/tcl/generic/tclIO.c
index 0c54c12a0da1..f501357c514a 100644
--- a/contrib/tcl/generic/tclIO.c
+++ b/contrib/tcl/generic/tclIO.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclIO.c 1.211 96/04/18 09:59:06
+ * SCCS: @(#) tclIO.c 1.227 96/07/30 09:26:30
*/
#include "tclInt.h"
@@ -203,6 +203,13 @@ typedef struct Channel {
#define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input
* translation mode and the last
* byte seen was a "\r". */
+#define CHANNEL_DEAD (1<<13) /* The channel has been closed by
+ * the exit handler (on exit) but
+ * not deallocated. When any IO
+ * operation sees this flag on a
+ * channel, it does not call driver
+ * level functions to avoid referring
+ * to deallocated data. */
/*
* For each channel handler registered in a call to Tcl_CreateChannelHandler,
@@ -282,13 +289,6 @@ typedef struct ChannelHandlerEvent {
} ChannelHandlerEvent;
/*
- * Static buffer used to sprintf channel option values and return
- * them to the caller.
- */
-
-static char optionVal[128];
-
-/*
* Static variables to hold channels for stdin, stdout and stderr.
*/
@@ -315,6 +315,8 @@ static void ChannelHandlerSetupProc _ANSI_ARGS_((
ClientData clientData, int flags));
static void ChannelEventScriptInvoker _ANSI_ARGS_((
ClientData clientData, int flags));
+static void CleanupChannelHandlers _ANSI_ARGS_((
+ Tcl_Interp *interp, Channel *chanPtr));
static int CloseChannel _ANSI_ARGS_((Tcl_Interp *interp,
Channel *chanPtr, int errorCode));
static void CloseChannelsOnExit _ANSI_ARGS_((ClientData data));
@@ -352,6 +354,50 @@ static int ScanInputForEOL _ANSI_ARGS_((Channel *chanPtr,
/*
*----------------------------------------------------------------------
*
+ * TclFindChannel --
+ *
+ * Finds a channel given two Tcl_Files.
+ *
+ * Results:
+ * The Tcl_Channel found. Also returns nonzero in fileUsedPtr output
+ * parameter if it finds that the Tcl_File is already used in another
+ * channel.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+TclFindFileChannel(inFile, outFile, fileUsedPtr)
+ Tcl_File inFile, outFile; /* Channel has these Tcl_Files. */
+ int *fileUsedPtr;
+{
+ Channel *chanPtr;
+
+ *fileUsedPtr = 0;
+ for (chanPtr = firstChanPtr;
+ chanPtr != (Channel *) NULL;
+ chanPtr = chanPtr->nextChanPtr) {
+ if ((chanPtr->inFile == inFile) && (chanPtr->outFile == outFile)) {
+ return (Tcl_Channel) chanPtr;
+ }
+ if ((inFile != (Tcl_File) NULL) && (chanPtr->inFile == inFile)) {
+ *fileUsedPtr = 1;
+ return (Tcl_Channel) NULL;
+ }
+ if ((outFile != (Tcl_File) NULL) && (chanPtr->outFile == outFile)) {
+ *fileUsedPtr = 1;
+ return (Tcl_Channel) NULL;
+ }
+ }
+ return (Tcl_Channel) NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_SetStdChannel --
*
* This function is used to change the channels that are used
@@ -373,7 +419,7 @@ Tcl_SetStdChannel(channel, type)
{
switch (type) {
case TCL_STDIN:
- stdinInitialized = 1;
+ stdinInitialized = 1;
stdinChannel = channel;
break;
case TCL_STDOUT:
@@ -564,22 +610,48 @@ CloseChannelsOnExit(clientData)
nextChanPtr = chanPtr->nextChanPtr;
/*
- * Close it only if the refcount indicates that the channel is not
- * referenced from any interpreter. If it is, that interpreter will
- * close the channel when it gets destroyed.
+ * Set the channel back into blocking mode to ensure that we wait
+ * for all data to flush out.
*/
+
+ (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
+ "-blocking", "on");
if (chanPtr->refCount <= 0) {
-
+
+ /*
+ * Close it only if the refcount indicates that the channel is not
+ * referenced from any interpreter. If it is, that interpreter will
+ * close the channel when it gets destroyed.
+ */
+
+ Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
+ } else {
+
/*
- * Switch the channel back into synchronous mode to ensure that it
- * gets flushed now.
+ * The refcount is greater than zero, so flush the channel.
*/
- (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
- "-blocking", "on");
+ Tcl_Flush((Tcl_Channel) chanPtr);
- Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
+ /*
+ * And close the OS level handles using the driver function:
+ */
+
+ (chanPtr->typePtr->closeProc) (chanPtr->instanceData,
+ (Tcl_Interp *) NULL, chanPtr->inFile, chanPtr->outFile);
+
+ /*
+ * Finally, we clean up the fields in the channel data structure
+ * since all of them have been deleted already. We mark the
+ * channel with CHANNEL_DEAD to prevent any further IO operations
+ * on it.
+ */
+
+ chanPtr->inFile = (Tcl_File) NULL;
+ chanPtr->outFile = (Tcl_File) NULL;
+ chanPtr->instanceData = (ClientData) NULL;
+ chanPtr->flags |= CHANNEL_DEAD;
}
}
}
@@ -609,7 +681,7 @@ GetChannelTable(interp)
Tcl_Interp *interp;
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
- Tcl_Channel stdinChannel, stdoutChannel, stderrChannel;
+ Tcl_Channel stdinChan, stdoutChan, stderrChan;
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
@@ -627,17 +699,17 @@ GetChannelTable(interp)
*/
if (Tcl_IsSafe(interp) == 0) {
- stdinChannel = Tcl_GetStdChannel(TCL_STDIN);
- if (stdinChannel != NULL) {
- Tcl_RegisterChannel(interp, stdinChannel);
+ stdinChan = Tcl_GetStdChannel(TCL_STDIN);
+ if (stdinChan != NULL) {
+ Tcl_RegisterChannel(interp, stdinChan);
}
- stdoutChannel = Tcl_GetStdChannel(TCL_STDOUT);
- if (stdoutChannel != NULL) {
- Tcl_RegisterChannel(interp, stdoutChannel);
+ stdoutChan = Tcl_GetStdChannel(TCL_STDOUT);
+ if (stdoutChan != NULL) {
+ Tcl_RegisterChannel(interp, stdoutChan);
}
- stderrChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (stderrChannel != NULL) {
- Tcl_RegisterChannel(interp, stderrChannel);
+ stderrChan = Tcl_GetStdChannel(TCL_STDERR);
+ if (stderrChan != NULL) {
+ Tcl_RegisterChannel(interp, stderrChan);
}
}
@@ -776,8 +848,29 @@ Tcl_UnregisterChannel(interp, chan)
return TCL_OK;
}
Tcl_DeleteHashEntry(hPtr);
+
+ /*
+ * Remove channel handlers that refer to this interpreter, so that they
+ * will not be present if the actual close is delayed and more events
+ * happen on the channel. This may occur if the channel is shared between
+ * several interpreters, or if the channel has async flushing active.
+ */
+
+ CleanupChannelHandlers(interp, chanPtr);
+
chanPtr->refCount--;
if (chanPtr->refCount <= 0) {
+
+ /*
+ * Ensure that if there is another buffer, it gets flushed
+ * whether or not we are doing a background flush.
+ */
+
+ if ((chanPtr->curOutPtr != NULL) &&
+ (chanPtr->curOutPtr->nextAdded >
+ chanPtr->curOutPtr->nextRemoved)) {
+ chanPtr->flags |= BUFFER_READY;
+ }
chanPtr->flags |= CHANNEL_CLOSED;
if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) {
if (Tcl_Close(interp, chan) != TCL_OK) {
@@ -995,7 +1088,7 @@ Tcl_CreateChannel(typePtr, chanName, inFile, outFile, instanceData)
channelExitHandlerCreated = 1;
Tcl_CreateExitHandler(CloseChannelsOnExit, (ClientData) NULL);
}
-
+
/*
* Install this channel in the first empty standard channel slot.
*/
@@ -1272,6 +1365,18 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
* channel driver operations. */
errorCode = 0;
+
+ /*
+ * Prevent writing on a dead channel -- a channel that has been closed
+ * but not yet deallocated. This can occur if the exit handler for the
+ * channel deallocation runs before all channels are deregistered in
+ * all interpreters.
+ */
+
+ if (chanPtr->flags & CHANNEL_DEAD) {
+ Tcl_SetErrno(EINVAL);
+ return -1;
+ }
/*
* Loop over the queued buffers and attempt to flush as
@@ -1342,6 +1447,7 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
*/
if (errorCode == EINTR) {
+ errorCode = 0;
continue;
}
@@ -1370,6 +1476,7 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
*/
TclWaitForFile(chanPtr->outFile, TCL_WRITABLE, -1);
+ errorCode = 0;
continue;
}
}
@@ -1464,12 +1571,25 @@ CloseChannel(interp, chanPtr, errorCode)
Channel *chanPtr; /* The channel to close. */
int errorCode; /* Status of operation so far. */
{
- int result; /* Of calling driver close
+ int result = 0; /* Of calling driver close
* operation. */
Channel *prevChanPtr; /* Preceding channel in list of
* all channels - used to splice a
* channel out of the list on close. */
+
+ /*
+ * Remove the channel from the standard channel table.
+ */
+
+ if (Tcl_GetStdChannel(TCL_STDIN) == (Tcl_Channel) chanPtr) {
+ Tcl_SetStdChannel(NULL, TCL_STDIN);
+ } else if (Tcl_GetStdChannel(TCL_STDOUT) == (Tcl_Channel) chanPtr) {
+ Tcl_SetStdChannel(NULL, TCL_STDOUT);
+ } else if (Tcl_GetStdChannel(TCL_STDERR) == (Tcl_Channel) chanPtr) {
+ Tcl_SetStdChannel(NULL, TCL_STDERR);
+ }
+
/*
* No more input can be consumed so discard any leftover input.
*/
@@ -1504,8 +1624,10 @@ CloseChannel(interp, chanPtr, errorCode)
char c;
c = (char) chanPtr->outEofChar;
- (chanPtr->typePtr->outputProc) (chanPtr->instanceData,
- chanPtr->outFile, &c, 1, &dummy);
+ if (!(chanPtr->flags & CHANNEL_DEAD)) {
+ (chanPtr->typePtr->outputProc) (chanPtr->instanceData,
+ chanPtr->outFile, &c, 1, &dummy);
+ }
}
/*
@@ -1537,16 +1659,17 @@ CloseChannel(interp, chanPtr, errorCode)
prevChanPtr->nextChanPtr = chanPtr->nextChanPtr;
}
- if (chanPtr->channelName != (char *) NULL) {
- ckfree(chanPtr->channelName);
- }
-
/*
* OK, close the channel itself.
*/
- result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp,
- chanPtr->inFile, chanPtr->outFile);
+ if (!(chanPtr->flags & CHANNEL_DEAD)) {
+ result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp,
+ chanPtr->inFile, chanPtr->outFile);
+ }
+ if (chanPtr->channelName != (char *) NULL) {
+ ckfree(chanPtr->channelName);
+ }
/*
* If we are being called synchronously, report either
@@ -1610,18 +1733,6 @@ Tcl_Close(interp, chan)
if (chanPtr->refCount > 0) {
panic("called Tcl_Close on channel with refcount > 0");
}
-
- /*
- * Remove the channel from the standard channel table.
- */
-
- if (Tcl_GetStdChannel(TCL_STDIN) == chan) {
- Tcl_SetStdChannel(NULL, TCL_STDIN);
- } else if (Tcl_GetStdChannel(TCL_STDOUT) == chan) {
- Tcl_SetStdChannel(NULL, TCL_STDOUT);
- } else if (Tcl_GetStdChannel(TCL_STDERR) == chan) {
- Tcl_SetStdChannel(NULL, TCL_STDERR);
- }
/*
* Remove all the channel handler records attached to the channel
@@ -2066,6 +2177,18 @@ GetInput(chanPtr)
ChannelBuffer *bufPtr; /* New buffer to add to input queue. */
/*
+ * Prevent reading from a dead channel -- a channel that has been closed
+ * but not yet deallocated, which can happen if the exit handler for
+ * channel cleanup has run but the channel is still registered in some
+ * interpreter.
+ */
+
+ if (chanPtr->flags & CHANNEL_DEAD) {
+ Tcl_SetErrno(EINVAL);
+ return -1;
+ }
+
+ /*
* See if we can fill an existing buffer. If we can, read only
* as much as will fit in it. Otherwise allocate a new buffer,
* add it to the input queue and attempt to fill it to the max.
@@ -2894,6 +3017,18 @@ Tcl_Seek(chan, offset, mode)
}
/*
+ * Disallow seek on dead channels -- channels that have been closed but
+ * not yet been deallocated. Such channels can be found if the exit
+ * handler for channel cleanup has run but the channel is still
+ * registered in an interpreter.
+ */
+
+ if (chanPtr->flags & CHANNEL_DEAD) {
+ Tcl_SetErrno(EINVAL);
+ return -1;
+ }
+
+ /*
* Disallow seek on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
@@ -3070,6 +3205,18 @@ Tcl_Tell(chan)
}
/*
+ * Disallow tell on dead channels -- channels that have been closed but
+ * not yet been deallocated. Such channels can be found if the exit
+ * handler for channel cleanup has run but the channel is still
+ * registered in an interpreter.
+ */
+
+ if (chanPtr->flags & CHANNEL_DEAD) {
+ Tcl_SetErrno(EINVAL);
+ return -1;
+ }
+
+ /*
* Disallow tell on channels that are open for neither
* writing nor reading (e.g. socket server channels).
*/
@@ -3316,10 +3463,23 @@ Tcl_GetChannelOption(chan, optionName, dsPtr)
{
Channel *chanPtr; /* The real IO channel. */
size_t len; /* Length of optionName string. */
+ char optionVal[128]; /* Buffer for sprintf. */
chanPtr = (Channel *) chan;
/*
+ * Disallow options on dead channels -- channels that have been closed but
+ * not yet been deallocated. Such channels can be found if the exit
+ * handler for channel cleanup has run but the channel is still
+ * registered in an interpreter.
+ */
+
+ if (chanPtr->flags & CHANNEL_DEAD) {
+ Tcl_SetErrno(EINVAL);
+ return TCL_ERROR;
+ }
+
+ /*
* If the optionName is NULL it means that we want a list of all
* options and values.
*/
@@ -3374,8 +3534,8 @@ Tcl_GetChannelOption(chan, optionName, dsPtr)
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-eofchar");
}
- if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
- (TCL_READABLE|TCL_WRITABLE)) {
+ if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
+ (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringStartSublist(dsPtr);
}
if (chanPtr->flags & TCL_READABLE) {
@@ -3398,8 +3558,8 @@ Tcl_GetChannelOption(chan, optionName, dsPtr)
Tcl_DStringAppendElement(dsPtr, buf);
}
}
- if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
- (TCL_READABLE|TCL_WRITABLE)) {
+ if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
+ (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringEndSublist(dsPtr);
}
if (len > 0) {
@@ -3412,8 +3572,8 @@ Tcl_GetChannelOption(chan, optionName, dsPtr)
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-translation");
}
- if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
- (TCL_READABLE|TCL_WRITABLE)) {
+ if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
+ (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringStartSublist(dsPtr);
}
if (chanPtr->flags & TCL_READABLE) {
@@ -3438,8 +3598,8 @@ Tcl_GetChannelOption(chan, optionName, dsPtr)
Tcl_DStringAppendElement(dsPtr, "lf");
}
}
- if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
- (TCL_READABLE|TCL_WRITABLE)) {
+ if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
+ (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringEndSublist(dsPtr);
}
if (len > 0) {
@@ -3489,6 +3649,18 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
char **argv;
chanPtr = (Channel *) chan;
+
+ /*
+ * Disallow options on dead channels -- channels that have been closed but
+ * not yet been deallocated. Such channels can be found if the exit
+ * handler for channel cleanup has run but the channel is still
+ * registered in an interpreter.
+ */
+
+ if (chanPtr->flags & CHANNEL_DEAD) {
+ Tcl_SetErrno(EINVAL);
+ return -1;
+ }
len = strlen(optionName);
@@ -3770,6 +3942,61 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
/*
*----------------------------------------------------------------------
*
+ * CleanupChannelHandlers --
+ *
+ * Removes channel handlers that refer to the supplied interpreter,
+ * so that if the actual channel is not closed now, these handlers
+ * will not run on subsequent events on the channel. This would be
+ * erroneous, because the interpreter no longer has a reference to
+ * this channel.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Removes channel handlers.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+CleanupChannelHandlers(interp, chanPtr)
+ Tcl_Interp *interp;
+ Channel *chanPtr;
+{
+ EventScriptRecord *sPtr, *prevPtr, *nextPtr;
+
+ /*
+ * Remove fileevent records on this channel that refer to the
+ * given interpreter.
+ */
+
+ for (sPtr = chanPtr->scriptRecordPtr,
+ prevPtr = (EventScriptRecord *) NULL;
+ sPtr != (EventScriptRecord *) NULL;
+ sPtr = nextPtr) {
+ nextPtr = sPtr->nextPtr;
+ if (sPtr->interp == interp) {
+ if (prevPtr == (EventScriptRecord *) NULL) {
+ chanPtr->scriptRecordPtr = nextPtr;
+ } else {
+ prevPtr->nextPtr = nextPtr;
+ }
+
+ Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
+ ChannelEventScriptInvoker, (ClientData) sPtr);
+
+ Tcl_EventuallyFree((ClientData) sPtr->script, TCL_DYNAMIC);
+ ckfree((char *) sPtr);
+ } else {
+ prevPtr = sPtr;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ChannelEventSourceExitProc --
*
* This procedure is called during exit cleanup to delete the channel
@@ -4464,11 +4691,14 @@ ChannelEventScriptInvoker(clientData, mask)
/*
* On error, cause a background error and remove the channel handler
* and the script record.
+ *
+ * NOTE: Must delete channel handler before causing the background error
+ * because the background error may want to reinstall the handler.
*/
if (result != TCL_OK) {
- Tcl_BackgroundError(interp);
DeleteScriptRecord(interp, chanPtr, mask);
+ Tcl_BackgroundError(interp);
}
Tcl_Release((ClientData) chanPtr);
Tcl_Release((ClientData) script);
diff --git a/contrib/tcl/generic/tclIOCmd.c b/contrib/tcl/generic/tclIOCmd.c
index d852388a5cf5..f6c5abd800a5 100644
--- a/contrib/tcl/generic/tclIOCmd.c
+++ b/contrib/tcl/generic/tclIOCmd.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclIOCmd.c 1.94 96/04/15 06:40:02
+ * SCCS: @(#) tclIOCmd.c 1.96 96/05/10 15:20:56
*/
#include "tclInt.h"
diff --git a/contrib/tcl/generic/tclIOUtil.c b/contrib/tcl/generic/tclIOUtil.c
index 16f97acb048b..f42e16bbd634 100644
--- a/contrib/tcl/generic/tclIOUtil.c
+++ b/contrib/tcl/generic/tclIOUtil.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclIOUtil.c 1.122 96/04/02 18:46:40
+ * SCCS: @(#) tclIOUtil.c 1.123 96/04/29 14:08:24
*/
#include "tclInt.h"
@@ -497,10 +497,10 @@ Tcl_ReapDetachedProcs()
register Detached *detPtr;
Detached *nextPtr, *prevPtr;
int status;
- pid_t pid;
+ int pid;
for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
- pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
+ pid = (int) Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
if ((pid == 0) || ((pid == -1) && (errno != ECHILD))) {
prevPtr = detPtr;
detPtr = detPtr->nextPtr;
diff --git a/contrib/tcl/generic/tclInt.h b/contrib/tcl/generic/tclInt.h
index 079f916f0460..b86ad1310cc5 100644
--- a/contrib/tcl/generic/tclInt.h
+++ b/contrib/tcl/generic/tclInt.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclInt.h 1.200 96/04/11 17:24:12
+ * SCCS: @(#) tclInt.h 1.203 96/07/23 16:15:24
*/
#ifndef _TCLINT
@@ -760,6 +760,7 @@ extern TclEventSource * tclFirstEventSourcePtr;
extern Tcl_ChannelType tclFileChannelType;
extern char * tclMemDumpFileName;
extern TclPlatformType tclPlatform;
+extern int tclInInterpreterDeletion;
/*
*----------------------------------------------------------------
@@ -804,11 +805,12 @@ EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp,
char *list, char **elementPtr, char **nextPtr,
int *sizePtr, int *bracePtr));
+EXTERN Tcl_Channel TclFindFileChannel _ANSI_ARGS_((Tcl_File inFile,
+ Tcl_File outFile, int *fileUsedPtr));
EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr,
char *procName));
EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr));
EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp *interp));
-EXTERN unsigned long TclGetClicks _ANSI_ARGS_((void));
EXTERN char * TclGetExtension _ANSI_ARGS_((char *name));
EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
@@ -819,17 +821,12 @@ EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type));
EXTERN char * TclGetEnv _ANSI_ARGS_((char *name));
EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp,
char *string, CallFrame **framePtrPtr));
-EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, int *seekFlagPtr));
-EXTERN unsigned long TclGetSeconds _ANSI_ARGS_((void));
-EXTERN void TclGetTime _ANSI_ARGS_((Tcl_Time *time));
-EXTERN int TclGetTimeZone _ANSI_ARGS_((unsigned long time));
-EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name,
- Tcl_DString *bufferPtr));
EXTERN int TclGetListIndex _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int *indexPtr));
EXTERN int TclGetLoadedPackages _ANSI_ARGS_((Tcl_Interp *interp,
char *targetName));
+EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, int *seekFlagPtr));
EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name,
Tcl_DString *bufferPtr));
EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName,
@@ -862,6 +859,11 @@ EXTERN int TclParseWords _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int flags, int maxWords,
char **termPtr, int *argcPtr, char **argv,
ParseValue *pvPtr));
+EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void));
+EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void));
+EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time));
+EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
+EXTERN char * TclpGetTZName _ANSI_ARGS_((void));
EXTERN void TclPlatformExit _ANSI_ARGS_((int status));
EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData,
diff --git a/contrib/tcl/generic/tclInterp.c b/contrib/tcl/generic/tclInterp.c
index a791fd55cd7b..d2b7f1ae3357 100644
--- a/contrib/tcl/generic/tclInterp.c
+++ b/contrib/tcl/generic/tclInterp.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclInterp.c 1.66 96/04/15 17:26:10
+ * SCCS: @(#) tclInterp.c 1.73 96/06/11 18:14:22
*/
#include <stdio.h>
@@ -169,18 +169,18 @@ static char *TclCommandsToKeep[] = {
"break",
"case", "catch", "clock", "close", "concat", "continue",
"eof", "error", "eval", "expr",
- "fblocked", "fconfigure", "flush", "for", "foreach", "format",
+ "fblocked", "fileevent", "flush", "for", "foreach", "format",
"gets", "global",
"history",
"if", "incr", "info", "interp",
"join",
- "lappend", "lindex", "linsert", "list", "llength", "lower", "lrange",
- "lreplace", "lsearch", "lsort",
+ "lappend", "lindex", "linsert", "list", "llength",
+ "lower", "lrange", "lreplace", "lsearch", "lsort",
"package", "pid", "proc", "puts",
"read", "regexp", "regsub", "rename", "return",
- "scan", "seek", "set", "split", "string", "switch",
- "tell", "trace",
- "unset", "update", "uplevel", "upvar",
+ "scan", "seek", "set", "split", "string", "subst", "switch",
+ "tell", "time", "trace",
+ "unset", "unsupported0", "update", "uplevel", "upvar",
"vwait",
"while",
NULL};
diff --git a/contrib/tcl/generic/tclLoad.c b/contrib/tcl/generic/tclLoad.c
index f14856bae5ab..1c098aa29db2 100644
--- a/contrib/tcl/generic/tclLoad.c
+++ b/contrib/tcl/generic/tclLoad.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclLoad.c 1.10 96/04/02 18:44:22
+ * SCCS: @(#) tclLoad.c 1.11 96/07/29 08:39:29
*/
#include "tclInt.h"
@@ -373,6 +373,13 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
*/
if (code == TCL_OK) {
+ /*
+ * Refetch ipFirstPtr: loading the package may have introduced
+ * additional static packages at the head of the linked list!
+ */
+
+ ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
+ (Tcl_InterpDeleteProc **) NULL);
ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
diff --git a/contrib/tcl/generic/tclPosixStr.c b/contrib/tcl/generic/tclPosixStr.c
index 9f46ff8c72cb..1ac415c21619 100644
--- a/contrib/tcl/generic/tclPosixStr.c
+++ b/contrib/tcl/generic/tclPosixStr.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclPosixStr.c 1.30 96/02/08 16:33:34
+ * SCCS: @(#) tclPosixStr.c 1.31 96/07/28 16:25:29
*/
#include "tclInt.h"
@@ -117,7 +117,7 @@ Tcl_ErrnoId()
#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))
case EDEADLK: return "EDEADLK";
#endif
-#ifdef EDEADLOCK
+#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK))
case EDEADLOCK: return "EDEADLOCK";
#endif
#ifdef EDESTADDRREQ
@@ -563,7 +563,7 @@ Tcl_ErrnoMsg(err)
#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))
case EDEADLK: return "resource deadlock avoided";
#endif
-#ifdef EDEADLOCK
+#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK))
case EDEADLOCK: return "resource deadlock avoided";
#endif
#ifdef EDESTADDRREQ
diff --git a/contrib/tcl/generic/tclPreserve.c b/contrib/tcl/generic/tclPreserve.c
index 714fb54cd12a..947873d71008 100644
--- a/contrib/tcl/generic/tclPreserve.c
+++ b/contrib/tcl/generic/tclPreserve.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclPreserve.c 1.14 96/03/20 08:24:37
+ * SCCS: @(#) tclPreserve.c 1.17 96/07/23 16:15:34
*/
#include "tclInt.h"
@@ -148,6 +148,7 @@ Tcl_Preserve(clientData)
refPtr->clientData = clientData;
refPtr->refCount = 1;
refPtr->mustFree = 0;
+ refPtr->freeProc = TCL_STATIC;
inUse += 1;
}
@@ -267,7 +268,8 @@ Tcl_EventuallyFree(clientData, freeProc)
* No reference for this block. Free it now.
*/
- if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) {
+ if ((freeProc == TCL_DYNAMIC)
+ || (freeProc == (Tcl_FreeProc *) free)) {
ckfree((char *) clientData);
} else {
(*freeProc)((char *)clientData);
diff --git a/contrib/tcl/generic/tclUtil.c b/contrib/tcl/generic/tclUtil.c
index 5f83c58b7e7e..5c1553661564 100644
--- a/contrib/tcl/generic/tclUtil.c
+++ b/contrib/tcl/generic/tclUtil.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclUtil.c 1.112 96/02/15 11:42:52
+ * SCCS: @(#) tclUtil.c 1.114 96/06/06 13:48:58
*/
#include "tclInt.h"
@@ -977,9 +977,6 @@ Tcl_SetResult(interp, string, freeProc)
iPtr->resultSpace[0] = 0;
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
- } else if (freeProc == TCL_DYNAMIC) {
- iPtr->result = string;
- iPtr->freeProc = TCL_DYNAMIC;
} else if (freeProc == TCL_VOLATILE) {
length = strlen(string);
if (length > TCL_RESULT_SIZE) {