Initial import of the CDE 2.1.30 sources from the Open Group.

cde/programs/dtdocbook/tcl/Imakefile

@@ -0,0 +1,68 @@
+XCOMM $XConsortium: Imakefile /main/4 1996/08/08 14:42:19 cde-hp $
+#define DoNormalLib	YES
+#define DoSharedLib	NO
+#define DoDebugLib	NO
+#define DoProfileLib	NO
+#define LibName		tcl
+#define LibHeaders	NO
+#define LibInstall	NO
+
+VERSION = 7.5
+prefix =	/usr/local
+
+XCOMM Directory from which applications will reference the library of Tcl
+XCOMM scripts (note: you can set the TCL_LIBRARY environment variable at
+XCOMM run-time to override this value):
+TCL_LIBRARY =	$(prefix)/lib/tcl$(VERSION)
+
+#ifdef SunArchitecture
+EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
+	-DNO_UNION_WAIT -DHAVE_UNISTD_H \
+	-DTCL_GOT_TIMEZONE
+#else
+# ifdef IBMArchitecture
+EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
+	-DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR -Dvfork=fork \
+	-DTCL_GOT_TIMEZONE -DHAVE_SYS_SELECT_H
+# else
+#   ifdef AlphaArchitecture
+EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
+	-DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR \
+	-DTCL_GOT_TIMEZONE -DTIME_WITH_SYS_TIME
+
+#   else
+EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
+	-DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR \
+	-DTCL_GOT_TIMEZONE
+
+#   endif
+# endif
+#endif
+
+INCLUDES = -I.
+
+SRCS = panic.c regexp.c tclAsync.c tclBasic.c tclCkalloc.c        \
+       tclClock.c tclCmdAH.c tclCmdIL.c tclCmdMZ.c tclDate.c      \
+       tclEnv.c tclEvent.c tclExpr.c tclFHandle.c tclFileName.c   \
+       tclGet.c tclHash.c tclHistory.c tclIO.c tclIOCmd.c         \
+       tclIOSock.c tclIOUtil.c tclInterp.c tclLink.c tclLoad.c    \
+       tclLoadNone.c tclMain.c tclMtherr.c tclNotify.c tclParse.c \
+       tclPkg.c tclPosixStr.c tclPreserve.c tclProc.c             \
+       tclUnixChan.c tclUnixFile.c tclUnixInit.c tclUnixNotfy.c   \
+       tclUnixPipe.c tclUnixSock.c tclUnixTime.c tclUtil.c        \
+       tclVar.c
+
+OBJS = panic.o regexp.o tclAsync.o tclBasic.o tclCkalloc.o        \
+       tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclDate.o      \
+       tclEnv.o tclEvent.o tclExpr.o tclFHandle.o tclFileName.o   \
+       tclGet.o tclHash.o tclHistory.o tclIO.o tclIOCmd.o         \
+       tclIOSock.o tclIOUtil.o tclInterp.o tclLink.o tclLoad.o    \
+       tclLoadNone.o tclMain.o tclMtherr.o tclNotify.o tclParse.o \
+       tclPkg.o tclPosixStr.o tclPreserve.o tclProc.o             \
+       tclUnixChan.o tclUnixFile.o tclUnixInit.o tclUnixNotfy.o   \
+       tclUnixPipe.o tclUnixSock.o tclUnixTime.o tclUtil.o        \
+       tclVar.o
+
+#include <Library.tmpl>
+
+DependTarget()

cde/programs/dtdocbook/tcl/license.terms

@@ -0,0 +1,32 @@
+This software is copyrighted by the Regents of the University of
+California, Sun Microsystems, Inc., and other parties.  The following
+terms apply to all files associated with the software unless explicitly
+disclaimed in individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+RESTRICTED RIGHTS: Use, duplication or disclosure by the government
+is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
+of the Rights in Technical Data and Computer Software Clause as DFARS
+252.227-7013 and FAR 52.227-19.

cde/programs/dtdocbook/tcl/panic.c

@@ -0,0 +1,93 @@
+/* $XConsortium: panic.c /main/2 1996/08/08 14:42:24 cde-hp $ */
+/* 
+ * panic.c --
+ *
+ *	Source code for the "panic" library procedure for Tcl;
+ *	individual applications will probably override this with
+ *	an application-specific panic procedure.
+ *
+ * Copyright (c) 1988-1993 The Regents of the University of California.
+ * Copyright (c) 1994 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) panic.c 1.11 96/02/15 11:50:29
+ */
+
+#include <stdio.h>
+#ifdef NO_STDLIB_H
+#   include "../compat/stdlib.h"
+#else
+#   include <stdlib.h>
+#endif
+
+#include "tcl.h"
+
+/*
+ * The panicProc variable contains a pointer to an application
+ * specific panic procedure.
+ */
+
+void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL;
+
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetPanicProc --
+ *
+ *	Replace the default panic behavior with the specified functiion.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Sets the panicProc variable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetPanicProc(proc)
+    void (*proc) _ANSI_ARGS_(TCL_VARARGS(char *,format));
+{
+    panicProc = proc;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * panic --
+ *
+ *	Print an error message and kill the process.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The process dies, entering the debugger if possible.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* VARARGS ARGSUSED */
+void
+panic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8)
+    char *format;		/* Format string, suitable for passing to
+				 * fprintf. */
+    char *arg1, *arg2, *arg3;	/* Additional arguments (variable in number)
+				 * to pass to fprintf. */
+    char *arg4, *arg5, *arg6, *arg7, *arg8;
+{
+    if (panicProc != NULL) {
+	(void) (*panicProc)(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
+    } else {
+	(void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6,
+		arg7, arg8);
+	(void) fprintf(stderr, "\n");
+	(void) fflush(stderr);
+	abort();
+    }
+}

cde/programs/dtdocbook/tcl/patchlevel.h

@@ -0,0 +1,24 @@
+/* $XConsortium: patchlevel.h /main/2 1996/08/08 14:42:32 cde-hp $ */
+/*
+ * patchlevel.h --
+ *
+ * This file does nothing except define a "patch level" for Tcl.
+ * The patch level has the form "X.YpZ" where X.Y is the base
+ * release, and Z is a serial number that is used to sequence
+ * patches for a given release.  Thus 7.4p1 is the first patch
+ * to release 7.4, 7.4p2 is the patch that follows 7.4p1, and
+ * so on.  The "pZ" is omitted in an original new release, and
+ * it is replaced with "bZ" for beta releases or "aZ for alpha
+ * releases.  The patch level ensures that patches are applied
+ * in the correct order and only to appropriate sources.
+ *
+ * Copyright (c) 1993-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ *
+ * 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
+ */
+
+#define TCL_PATCH_LEVEL "7.5"

cde/programs/dtdocbook/tcl/tclAsync.c

@@ -0,0 +1,266 @@
+/* $XConsortium: tclAsync.c /main/2 1996/08/08 14:42:49 cde-hp $ */
+/* 
+ * tclAsync.c --
+ *
+ *	This file provides low-level support needed to invoke signal
+ *	handlers in a safe way.  The code here doesn't actually handle
+ *	signals, though.  This code is based on proposals made by
+ *	Mark Diekhans and Don Libes.
+ *
+ * Copyright (c) 1993 The Regents of the University of California.
+ * Copyright (c) 1994 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclAsync.c 1.6 96/02/15 11:46:15
+ */
+
+#include "tclInt.h"
+
+/*
+ * One of the following structures exists for each asynchronous
+ * handler:
+ */
+
+typedef struct AsyncHandler {
+    int ready;				/* Non-zero means this handler should
+					 * be invoked in the next call to
+					 * Tcl_AsyncInvoke. */
+    struct AsyncHandler *nextPtr;	/* Next in list of all handlers for
+					 * the process. */
+    Tcl_AsyncProc *proc;		/* Procedure to call when handler
+					 * is invoked. */
+    ClientData clientData;		/* Value to pass to handler when it
+					 * is invoked. */
+} AsyncHandler;
+
+/*
+ * The variables below maintain a list of all existing handlers.
+ */
+
+static AsyncHandler *firstHandler;	/* First handler defined for process,
+					 * or NULL if none. */
+static AsyncHandler *lastHandler;	/* Last handler or NULL. */
+
+/*
+ * The variable below is set to 1 whenever a handler becomes ready and
+ * it is cleared to zero whenever Tcl_AsyncInvoke is called.  It can be
+ * checked elsewhere in the application by calling Tcl_AsyncReady to see
+ * if Tcl_AsyncInvoke should be invoked.
+ */
+
+static int asyncReady = 0;
+
+/*
+ * The variable below indicates whether Tcl_AsyncInvoke is currently
+ * working.  If so then we won't set asyncReady again until
+ * Tcl_AsyncInvoke returns.
+ */
+
+static int asyncActive = 0;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AsyncCreate --
+ *
+ *	This procedure creates the data structures for an asynchronous
+ *	handler, so that no memory has to be allocated when the handler
+ *	is activated.
+ *
+ * Results:
+ *	The return value is a token for the handler, which can be used
+ *	to activate it later on.
+ *
+ * Side effects:
+ *	Information about the handler is recorded.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_AsyncHandler
+Tcl_AsyncCreate(proc, clientData)
+    Tcl_AsyncProc *proc;		/* Procedure to call when handler
+					 * is invoked. */
+    ClientData clientData;		/* Argument to pass to handler. */
+{
+    AsyncHandler *asyncPtr;
+
+    asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler));
+    asyncPtr->ready = 0;
+    asyncPtr->nextPtr = NULL;
+    asyncPtr->proc = proc;
+    asyncPtr->clientData = clientData;
+    if (firstHandler == NULL) {
+	firstHandler = asyncPtr;
+    } else {
+	lastHandler->nextPtr = asyncPtr;
+    }
+    lastHandler = asyncPtr;
+    return (Tcl_AsyncHandler) asyncPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AsyncMark --
+ *
+ *	This procedure is called to request that an asynchronous handler
+ *	be invoked as soon as possible.  It's typically called from
+ *	an interrupt handler, where it isn't safe to do anything that
+ *	depends on or modifies application state.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The handler gets marked for invocation later.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AsyncMark(async)
+    Tcl_AsyncHandler async;		/* Token for handler. */
+{
+    ((AsyncHandler *) async)->ready = 1;
+    if (!asyncActive) {
+	asyncReady = 1;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AsyncInvoke --
+ *
+ *	This procedure is called at a "safe" time at background level
+ *	to invoke any active asynchronous handlers.
+ *
+ * Results:
+ *	The return value is a normal Tcl result, which is intended to
+ *	replace the code argument as the current completion code for
+ *	interp.
+ *
+ * Side effects:
+ *	Depends on the handlers that are active.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AsyncInvoke(interp, code)
+    Tcl_Interp *interp;			/* If invoked from Tcl_Eval just after
+					 * completing a command, points to
+					 * interpreter.  Otherwise it is
+					 * NULL. */
+    int code; 				/* If interp is non-NULL, this gives
+					 * completion code from command that
+					 * just completed. */
+{
+    AsyncHandler *asyncPtr;
+
+    if (asyncReady == 0) {
+	return code;
+    }
+    asyncReady = 0;
+    asyncActive = 1;
+    if (interp == NULL) {
+	code = 0;
+    }
+
+    /*
+     * Make one or more passes over the list of handlers, invoking
+     * at most one handler in each pass.  After invoking a handler,
+     * go back to the start of the list again so that (a) if a new
+     * higher-priority handler gets marked while executing a lower
+     * priority handler, we execute the higher-priority handler
+     * next, and (b) if a handler gets deleted during the execution
+     * of a handler, then the list structure may change so it isn't
+     * safe to continue down the list anyway.
+     */
+
+    while (1) {
+	for (asyncPtr = firstHandler; asyncPtr != NULL;
+		asyncPtr = asyncPtr->nextPtr) {
+	    if (asyncPtr->ready) {
+		break;
+	    }
+	}
+	if (asyncPtr == NULL) {
+	    break;
+	}
+	asyncPtr->ready = 0;
+	code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code);
+    }
+    asyncActive = 0;
+    return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AsyncDelete --
+ *
+ *	Frees up all the state for an asynchronous handler.  The handler
+ *	should never be used again.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The state associated with the handler is deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AsyncDelete(async)
+    Tcl_AsyncHandler async;		/* Token for handler to delete. */
+{
+    AsyncHandler *asyncPtr = (AsyncHandler *) async;
+    AsyncHandler *prevPtr;
+
+    if (firstHandler == asyncPtr) {
+	firstHandler = asyncPtr->nextPtr;
+	if (firstHandler == NULL) {
+	    lastHandler = NULL;
+	}
+    } else {
+	prevPtr = firstHandler;
+	while (prevPtr->nextPtr != asyncPtr) {
+	    prevPtr = prevPtr->nextPtr;
+	}
+	prevPtr->nextPtr = asyncPtr->nextPtr;
+	if (lastHandler == asyncPtr) {
+	    lastHandler = prevPtr;
+	}
+    }
+    ckfree((char *) asyncPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AsyncReady --
+ *
+ *	This procedure can be used to tell whether Tcl_AsyncInvoke
+ *	needs to be called.  This procedure is the external interface
+ *	for checking the internal asyncReady variable.
+ *
+ * Results:
+ * 	The return value is 1 whenever a handler is ready and is 0
+ *	when no handlers are ready.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AsyncReady()
+{
+    return asyncReady;
+}

cde/programs/dtdocbook/tcl/tclCkalloc.c

@@ -0,0 +1,739 @@
+/* $XConsortium: tclCkalloc.c /main/2 1996/08/08 14:42:59 cde-hp $ */
+/* 
+ * tclCkalloc.c --
+ *
+ *    Interface to malloc and free that provides support for debugging problems
+ *    involving overwritten, double freeing memory and loss of memory.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * This code contributed by Karl Lehenbauer and Mark Diekhans
+ *
+ *
+ * SCCS: @(#) tclCkalloc.c 1.17 96/03/14 13:05:56
+ */
+
+#include "tclInt.h"
+
+#define FALSE	0
+#define TRUE	1
+
+#ifdef TCL_MEM_DEBUG
+#ifndef TCL_GENERIC_ONLY
+#include "tclPort.h"
+#endif
+
+/*
+ * One of the following structures is allocated each time the
+ * "memory tag" command is invoked, to hold the current tag.
+ */
+
+typedef struct MemTag {
+    int refCount;		/* Number of mem_headers referencing
+				 * this tag. */
+    char string[4];		/* Actual size of string will be as
+				 * large as needed for actual tag.  This
+				 * must be the last field in the structure. */
+} MemTag;
+
+#define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3)
+
+static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers
+				 * (set by "memory tag" command). */
+
+/*
+ * One of the following structures is allocated just before each
+ * dynamically allocated chunk of memory, both to record information
+ * about the chunk and to help detect chunk under-runs.
+ */
+
+#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)
+struct mem_header {
+    struct mem_header *flink;
+    struct mem_header *blink;
+    MemTag *tagPtr;		/* Tag from "memory tag" command;  may be
+				 * NULL. */
+    char *file;
+    long length;
+    int line;
+    unsigned char low_guard[LOW_GUARD_SIZE];
+				/* Aligns body on 8-byte boundary, plus
+				 * provides at least 8 additional guard bytes
+				 * to detect underruns. */
+    char body[1];		/* First byte of client's space.  Actual
+				 * size of this field will be larger than
+				 * one. */
+};
+
+static struct mem_header *allocHead = NULL;  /* List of allocated structures */
+
+#define GUARD_VALUE  0141
+
+/*
+ * The following macro determines the amount of guard space *above* each
+ * chunk of memory.
+ */
+
+#define HIGH_GUARD_SIZE 8
+
+/*
+ * The following macro computes the offset of the "body" field within
+ * mem_header.  It is used to get back to the header pointer from the
+ * body pointer that's used by clients.
+ */
+
+#define BODY_OFFSET \
+	((unsigned long) (&((struct mem_header *) 0)->body))
+
+static int total_mallocs = 0;
+static int total_frees = 0;
+static int current_bytes_malloced = 0;
+static int maximum_bytes_malloced = 0;
+static int current_malloc_packets = 0;
+static int maximum_malloc_packets = 0;
+static int break_on_malloc = 0;
+static int trace_on_at_malloc = 0;
+static int  alloc_tracing = FALSE;
+static int  init_malloced_bodies = TRUE;
+#ifdef MEM_VALIDATE
+    static int  validate_memory = TRUE;
+#else
+    static int  validate_memory = FALSE;
+#endif
+
+/*
+ * Prototypes for procedures defined in this file:
+ */
+
+static int		MemoryCmd _ANSI_ARGS_((ClientData clientData,
+			    Tcl_Interp *interp, int argc, char **argv));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * dump_memory_info --
+ *     Display the global memory management statistics.
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+dump_memory_info(outFile) 
+    FILE *outFile;
+{
+        fprintf(outFile,"total mallocs             %10d\n", 
+                total_mallocs);
+        fprintf(outFile,"total frees               %10d\n", 
+                total_frees);
+        fprintf(outFile,"current packets allocated %10d\n", 
+                current_malloc_packets);
+        fprintf(outFile,"current bytes allocated   %10d\n", 
+                current_bytes_malloced);
+        fprintf(outFile,"maximum packets allocated %10d\n", 
+                maximum_malloc_packets);
+        fprintf(outFile,"maximum bytes allocated   %10d\n", 
+                maximum_bytes_malloced);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ValidateMemory --
+ *     Procedure to validate allocted memory guard zones.
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+ValidateMemory (memHeaderP, file, line, nukeGuards)
+    struct mem_header *memHeaderP;
+    char              *file;
+    int                line;
+    int                nukeGuards;
+{
+    unsigned char *hiPtr;
+    int   idx;
+    int   guard_failed = FALSE;
+    int byte;
+    
+    for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
+        byte = *(memHeaderP->low_guard + idx);
+        if (byte != GUARD_VALUE) {
+            guard_failed = TRUE;
+            fflush (stdout);
+	    byte &= 0xff;
+            fprintf(stderr, "low guard byte %d is 0x%x  \t%c\n", idx, byte,
+		    (isprint(UCHAR(byte)) ? byte : ' '));
+        }
+    }
+    if (guard_failed) {
+        dump_memory_info (stderr);
+        fprintf (stderr, "low guard failed at %lx, %s %d\n",
+                 (long unsigned int) memHeaderP->body, file, line);
+        fflush (stderr);  /* In case name pointer is bad. */
+        fprintf (stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
+		memHeaderP->file, memHeaderP->line);
+        panic ("Memory validation failure");
+    }
+
+    hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
+    for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {
+        byte = *(hiPtr + idx);
+        if (byte != GUARD_VALUE) {
+            guard_failed = TRUE;
+            fflush (stdout);
+	    byte &= 0xff;
+            fprintf(stderr, "hi guard byte %d is 0x%x  \t%c\n", idx, byte,
+		    (isprint(UCHAR(byte)) ? byte : ' '));
+        }
+    }
+
+    if (guard_failed) {
+        dump_memory_info (stderr);
+        fprintf (stderr, "high guard failed at %lx, %s %d\n",
+                 (long unsigned int) memHeaderP->body, file, line);
+        fflush (stderr);  /* In case name pointer is bad. */
+        fprintf (stderr, "%ld bytes allocated at (%s %d)\n",
+		memHeaderP->length, memHeaderP->file,
+		memHeaderP->line);
+        panic ("Memory validation failure");
+    }
+
+    if (nukeGuards) {
+        memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); 
+        memset ((char *) hiPtr, 0, HIGH_GUARD_SIZE); 
+    }
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ValidateAllMemory --
+ *     Validates guard regions for all allocated memory.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+Tcl_ValidateAllMemory (file, line)
+    char  *file;
+    int    line;
+{
+    struct mem_header *memScanP;
+
+    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink)
+        ValidateMemory (memScanP, file, line, FALSE);
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DumpActiveMemory --
+ *     Displays all allocated memory to stderr.
+ *
+ * Results:
+ *     Return TCL_ERROR if an error accessing the file occures, `errno' 
+ *     will have the file error number left in it.
+ *----------------------------------------------------------------------
+ */
+int
+Tcl_DumpActiveMemory (fileName)
+    char *fileName;
+{
+    FILE              *fileP;
+    struct mem_header *memScanP;
+    char              *address;
+
+    fileP = fopen(fileName, "w");
+    if (fileP == NULL)
+        return TCL_ERROR;
+
+    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
+        address = &memScanP->body [0];
+        fprintf (fileP, "%8lx - %8lx  %7ld @ %s %d %s",
+		(long unsigned int) address,
+                 (long unsigned int) address + memScanP->length - 1,
+		 memScanP->length, memScanP->file, memScanP->line,
+		 (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
+	(void) fputc('\n', fileP);
+    }
+    fclose (fileP);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbCkalloc - debugging ckalloc
+ *
+ *        Allocate the requested amount of space plus some extra for
+ *        guard bands at both ends of the request, plus a size, panicing 
+ *        if there isn't enough space, then write in the guard bands
+ *        and return the address of the space in the middle that the
+ *        user asked for.
+ *
+ *        The second and third arguments are file and line, these contain
+ *        the filename and line number corresponding to the caller.
+ *        These are sent by the ckalloc macro; it uses the preprocessor
+ *        autodefines __FILE__ and __LINE__.
+ *
+ *----------------------------------------------------------------------
+ */
+char *
+Tcl_DbCkalloc(size, file, line)
+    unsigned int size;
+    char        *file;
+    int          line;
+{
+    struct mem_header *result;
+
+    if (validate_memory)
+        Tcl_ValidateAllMemory (file, line);
+
+    result = (struct mem_header *)malloc((unsigned)size + 
+                              sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+    if (result == NULL) {
+        fflush(stdout);
+        dump_memory_info(stderr);
+        panic("unable to alloc %d bytes, %s line %d", size, file, 
+              line);
+    }
+
+    /*
+     * Fill in guard zones and size.  Also initialize the contents of
+     * the block with bogus bytes to detect uses of initialized data.
+     * Link into allocated list.
+     */
+    if (init_malloced_bodies) {
+        memset ((VOID *) result, GUARD_VALUE,
+		size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+    } else {
+	memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
+	memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
+    }
+    result->length = size;
+    result->tagPtr = curTagPtr;
+    if (curTagPtr != NULL) {
+	curTagPtr->refCount++;
+    }
+    result->file = file;
+    result->line = line;
+    result->flink = allocHead;
+    result->blink = NULL;
+    if (allocHead != NULL)
+        allocHead->blink = result;
+    allocHead = result;
+
+    total_mallocs++;
+    if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
+        (void) fflush(stdout);
+        fprintf(stderr, "reached malloc trace enable point (%d)\n",
+                total_mallocs);
+        fflush(stderr);
+        alloc_tracing = TRUE;
+        trace_on_at_malloc = 0;
+    }
+
+    if (alloc_tracing)
+        fprintf(stderr,"ckalloc %lx %d %s %d\n",
+		(long unsigned int) result->body, size, file, line);
+
+    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
+        break_on_malloc = 0;
+        (void) fflush(stdout);
+        fprintf(stderr,"reached malloc break limit (%d)\n", 
+                total_mallocs);
+        fprintf(stderr, "program will now enter C debugger\n");
+        (void) fflush(stderr);
+	abort();
+    }
+
+    current_malloc_packets++;
+    if (current_malloc_packets > maximum_malloc_packets)
+        maximum_malloc_packets = current_malloc_packets;
+    current_bytes_malloced += size;
+    if (current_bytes_malloced > maximum_bytes_malloced)
+        maximum_bytes_malloced = current_bytes_malloced;
+
+    return result->body;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbCkfree - debugging ckfree
+ *
+ *        Verify that the low and high guards are intact, and if so
+ *        then free the buffer else panic.
+ *
+ *        The guards are erased after being checked to catch duplicate
+ *        frees.
+ *
+ *        The second and third arguments are file and line, these contain
+ *        the filename and line number corresponding to the caller.
+ *        These are sent by the ckfree macro; it uses the preprocessor
+ *        autodefines __FILE__ and __LINE__.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DbCkfree(ptr, file, line)
+    char *  ptr;
+    char     *file;
+    int       line;
+{
+    /*
+     * The following cast is *very* tricky.  Must convert the pointer
+     * to an integer before doing arithmetic on it, because otherwise
+     * the arithmetic will be done differently (and incorrectly) on
+     * word-addressed machines such as Crays (will subtract only bytes,
+     * even though BODY_OFFSET is in words on these machines).
+     */
+
+    struct mem_header *memp = (struct mem_header *)
+	    (((unsigned long) ptr) - BODY_OFFSET);
+
+    if (alloc_tracing)
+        fprintf(stderr, "ckfree %lx %ld %s %d\n",
+		(long unsigned int) memp->body, memp->length, file, line);
+
+    if (validate_memory)
+        Tcl_ValidateAllMemory (file, line);
+
+    ValidateMemory (memp, file, line, TRUE);
+    if (init_malloced_bodies) {
+	memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);
+    }
+
+    total_frees++;
+    current_malloc_packets--;
+    current_bytes_malloced -= memp->length;
+
+    if (memp->tagPtr != NULL) {
+	memp->tagPtr->refCount--;
+	if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {
+	    free((char *) memp->tagPtr);
+	}
+    }
+
+    /*
+     * Delink from allocated list
+     */
+    if (memp->flink != NULL)
+        memp->flink->blink = memp->blink;
+    if (memp->blink != NULL)
+        memp->blink->flink = memp->flink;
+    if (allocHead == memp)
+        allocHead = memp->flink;
+    free((char *) memp);
+    return 0;
+}
+
+/*
+ *--------------------------------------------------------------------
+ *
+ * Tcl_DbCkrealloc - debugging ckrealloc
+ *
+ *	Reallocate a chunk of memory by allocating a new one of the
+ *	right size, copying the old data to the new location, and then
+ *	freeing the old memory space, using all the memory checking
+ *	features of this package.
+ *
+ *--------------------------------------------------------------------
+ */
+char *
+Tcl_DbCkrealloc(ptr, size, file, line)
+    char *ptr;
+    unsigned int size;
+    char *file;
+    int line;
+{
+    char *new;
+    unsigned int copySize;
+
+    /*
+     * See comment from Tcl_DbCkfree before you change the following
+     * line.
+     */
+
+    struct mem_header *memp = (struct mem_header *)
+	    (((unsigned long) ptr) - BODY_OFFSET);
+
+    copySize = size;
+    if (copySize > memp->length) {
+	copySize = memp->length;
+    }
+    new = Tcl_DbCkalloc(size, file, line);
+    memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);
+    Tcl_DbCkfree(ptr, file, line);
+    return(new);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MemoryCmd --
+ *     Implements the TCL memory command:
+ *       memory info
+ *       memory display
+ *       break_on_malloc count
+ *       trace_on_at_malloc count
+ *       trace on|off
+ *       validate on|off
+ *
+ * Results:
+ *     Standard TCL results.
+ *
+ *----------------------------------------------------------------------
+ */
+	/* ARGSUSED */
+static int
+MemoryCmd (clientData, interp, argc, argv)
+    ClientData  clientData;
+    Tcl_Interp *interp;
+    int         argc;
+    char      **argv;
+{
+    char *fileName;
+    Tcl_DString buffer;
+    int result;
+
+    if (argc < 2) {
+	Tcl_AppendResult(interp, "wrong # args: should be \"",
+		argv[0], " option [args..]\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    if (strcmp(argv[1],"active") == 0) {
+        if (argc != 3) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"",
+		    argv[0], " active file\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+	if (fileName == NULL) {
+	    return TCL_ERROR;
+	}
+	result = Tcl_DumpActiveMemory (fileName);
+	Tcl_DStringFree(&buffer);
+	if (result != TCL_OK) {
+	    Tcl_AppendResult(interp, "error accessing ", argv[2], 
+		    (char *) NULL);
+	    return TCL_ERROR;
+	}
+	return TCL_OK;
+    }
+    if (strcmp(argv[1],"break_on_malloc") == 0) {
+        if (argc != 3) 
+            goto argError;
+        if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK)
+                return TCL_ERROR;
+        return TCL_OK;
+    }
+    if (strcmp(argv[1],"info") == 0) {
+        dump_memory_info(stdout);
+        return TCL_OK;
+    }
+    if (strcmp(argv[1],"init") == 0) {
+        if (argc != 3)
+            goto bad_suboption;
+        init_malloced_bodies = (strcmp(argv[2],"on") == 0);
+        return TCL_OK;
+    }
+    if (strcmp(argv[1],"tag") == 0) {
+	if (argc != 3) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " tag string\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
+	    free((char *) curTagPtr);
+	}
+	curTagPtr = (MemTag *) malloc(TAG_SIZE(strlen(argv[2])));
+	curTagPtr->refCount = 0;
+	strcpy(curTagPtr->string, argv[2]);
+	return TCL_OK;
+    }
+    if (strcmp(argv[1],"trace") == 0) {
+        if (argc != 3) 
+            goto bad_suboption;
+        alloc_tracing = (strcmp(argv[2],"on") == 0);
+        return TCL_OK;
+    }
+
+    if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
+        if (argc != 3) 
+            goto argError;
+        if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK)
+                return TCL_ERROR;
+         return TCL_OK;
+    }
+    if (strcmp(argv[1],"validate") == 0) {
+        if (argc != 3)
+             goto bad_suboption;
+        validate_memory = (strcmp(argv[2],"on") == 0);
+        return TCL_OK;
+    }
+
+    Tcl_AppendResult(interp, "bad option \"", argv[1],
+	    "\": should be active, break_on_malloc, info, init, ",
+	    "tag, trace, trace_on_at_malloc, or validate", (char *) NULL);
+    return TCL_ERROR;
+
+argError:
+    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+	    " ", argv[1], " count\"", (char *) NULL);
+    return TCL_ERROR;
+
+bad_suboption:
+    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+	    " ", argv[1], " on|off\"", (char *) NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitMemory --
+ *     Initialize the memory command.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+Tcl_InitMemory(interp)
+    Tcl_Interp *interp;
+{
+Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, 
+                  (Tcl_CmdDeleteProc *) NULL);
+}
+
+#else
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Ckalloc --
+ *     Interface to malloc when TCL_MEM_DEBUG is disabled.  It does check
+ *     that memory was actually allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+VOID *
+Tcl_Ckalloc (size)
+    unsigned int size;
+{
+        char *result;
+
+        result = malloc(size);
+        if (result == NULL) 
+                panic("unable to alloc %d bytes", size);
+        return result;
+}
+
+
+char *
+Tcl_DbCkalloc(size, file, line)
+    unsigned int size;
+    char        *file;
+    int          line;
+{
+    char *result;
+
+    result = (char *) malloc(size);
+
+    if (result == NULL) {
+        fflush(stdout);
+        panic("unable to alloc %d bytes, %s line %d", size, file, 
+              line);
+    }
+    return result;
+}
+
+char *
+Tcl_DbCkrealloc(ptr, size, file, line)
+    char *ptr;
+    unsigned int size;
+    char *file;
+    int line;
+{
+    char *result;
+
+    result = (char *) realloc(ptr, size);
+
+    if (result == NULL) {
+        fflush(stdout);
+        panic("unable to realloc %d bytes, %s line %d", size, file, 
+              line);
+    }
+    return result;
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TckCkfree --
+ *     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)
+    char *ptr;
+{
+        free (ptr);
+}
+
+int
+Tcl_DbCkfree(ptr, file, line)
+    char *  ptr;
+    char     *file;
+    int       line;
+{
+    free (ptr);
+    return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitMemory --
+ *     Dummy initialization for memory command, which is only available 
+ *     if TCL_MEM_DEBUG is on.
+ *
+ *----------------------------------------------------------------------
+ */
+	/* ARGSUSED */
+void
+Tcl_InitMemory(interp)
+    Tcl_Interp *interp;
+{
+}
+
+#undef Tcl_DumpActiveMemory
+#undef Tcl_ValidateAllMemory
+
+extern int		Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName));
+extern void		Tcl_ValidateAllMemory _ANSI_ARGS_((char *file,
+			    int line));
+
+int
+Tcl_DumpActiveMemory (fileName)
+    char *fileName;
+{
+    return TCL_OK;
+}
+
+void
+Tcl_ValidateAllMemory (file, line)
+    char  *file;
+    int    line;
+{
+}
+
+#endif

cde/programs/dtdocbook/tcl/tclClock.c

@@ -0,0 +1,354 @@
+/* $XConsortium: tclClock.c /main/2 1996/08/08 14:43:05 cde-hp $ */
+/* 
+ * tclClock.c --
+ *
+ *	Contains the time and date related commands.  This code
+ *	is derived from the time and date facilities of TclX,
+ *	by Mark Diekhans and Karl Lehenbauer.
+ *
+ * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * 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
+ */
+
+#include "tcl.h"
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * Function prototypes for local procedures in this file:
+ */
+
+static int		FormatClock _ANSI_ARGS_((Tcl_Interp *interp,
+			    unsigned long clockVal, int useGMT,
+			    char *format));
+static int		ParseTime _ANSI_ARGS_((Tcl_Interp *interp,
+			    char *string, unsigned long *timePtr));
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * Tcl_ClockCmd --
+ *
+ *	This procedure is invoked to process the "clock" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int
+Tcl_ClockCmd (dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    int c;
+    size_t length;
+    char **argPtr;
+    int useGMT = 0;
+    unsigned long clockVal;
+    
+    if (argc < 2) {
+	Tcl_AppendResult(interp, "wrong # args: should be \"",
+		argv[0], " option ?arg ...?\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    c = argv[1][0];
+    length = strlen(argv[1]);
+    if ((c == 'c') && (strncmp(argv[1], "clicks", length) == 0)) {
+	if (argc != 2) {
+	    Tcl_AppendResult(interp, "wrong # arguments: must be \"",
+		    argv[0], " clicks\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	sprintf(interp->result, "%lu", TclGetClicks());
+	return TCL_OK;
+    } else if ((c == 'f') && (strncmp(argv[1], "format", length) == 0)) {
+	char *format = "%a %b %d %X %Z %Y";
+	
+	if ((argc < 3) || (argc > 7)) {
+	    wrongFmtArgs:
+	    Tcl_AppendResult(interp, "wrong # args: ", argv [0], 
+		    " format clockval ?-format string? ?-gmt boolean?",
+		    (char *) NULL);
+	    return TCL_ERROR;
+	}
+
+	if (ParseTime(interp, argv[2], &clockVal) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+
+	argPtr = argv+3;
+	argc -= 3;
+	while ((argc > 1) && (argPtr[0][0] == '-')) {
+	    if (strcmp(argPtr[0], "-format") == 0) {
+	        format = argPtr[1];
+	    } else if (strcmp(argPtr[0], "-gmt") == 0) {
+		if (Tcl_GetBoolean(interp, argPtr[1], &useGMT) != TCL_OK) {
+		    return TCL_ERROR;
+		}
+	    } else {
+		Tcl_AppendResult(interp, "bad option \"", argPtr[0],
+			"\": must be -format or -gmt", (char *) NULL);
+		return TCL_ERROR;
+	    }
+	    argPtr += 2;
+	    argc -= 2;
+	}
+	if (argc != 0) {
+	    goto wrongFmtArgs;
+	}
+
+	return FormatClock(interp, clockVal, useGMT, format);
+    } else if ((c == 's') && (strncmp(argv[1], "scan", length) == 0)) {
+	unsigned long baseClock;
+	long zone;
+	char * baseStr = NULL;
+
+	if ((argc < 3) || (argc > 7)) {
+	    wrongScanArgs:
+	    Tcl_AppendResult (interp, "wrong # args: ", argv [0], 
+		    " scan dateString ?-base clockValue? ?-gmt boolean?",
+		    (char *) NULL);
+	    return TCL_ERROR;
+	}
+
+	argPtr = argv+3;
+	argc -= 3;
+	while ((argc > 1) && (argPtr[0][0] == '-')) {
+	    if (strcmp(argPtr[0], "-base") == 0) {
+	        baseStr = argPtr[1];
+	    } else if (strcmp(argPtr[0], "-gmt") == 0) {
+		if (Tcl_GetBoolean(interp, argPtr[1], &useGMT) != TCL_OK) {
+		    return TCL_ERROR;
+		}
+	    } else {
+		Tcl_AppendResult(interp, "bad option \"", argPtr[0],
+			"\": must be -base or -gmt", (char *) NULL);
+		return TCL_ERROR;
+	    }
+	    argPtr += 2;
+	    argc -= 2;
+	}
+	if (argc != 0) {
+	    goto wrongScanArgs;
+	}
+	
+	if (baseStr != NULL) {
+	    if (ParseTime(interp, baseStr, &baseClock) != TCL_OK)
+		return TCL_ERROR;
+	} else {
+	    baseClock = TclGetSeconds();
+	}
+
+	if (useGMT) {
+	    zone = -50000; /* Force GMT */
+	} else {
+	    zone = TclGetTimeZone(baseClock);
+	}
+
+	if (TclGetDate(argv[2], baseClock, zone, &clockVal) < 0) {
+	    Tcl_AppendResult(interp, "unable to convert date-time string \"",
+		    argv[2], "\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+
+	sprintf(interp->result, "%lu", (long) clockVal);
+	return TCL_OK;
+    } else if ((c == 's') && (strncmp(argv[1], "seconds", length) == 0)) {
+	if (argc != 2) {
+	    Tcl_AppendResult(interp, "wrong # arguments: must be \"",
+		    argv[0], " seconds\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	sprintf(interp->result, "%lu", TclGetSeconds());
+	return TCL_OK;
+    } else {
+	Tcl_AppendResult(interp, "unknown option \"", argv[1],
+		"\": must be clicks, format, scan, or seconds",
+		(char *) NULL);
+	return TCL_ERROR;
+    }
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * ParseTime --
+ *
+ *      Given a string, produce the corresponding time_t value.
+ *
+ * Results:
+ *      The return value is normally TCL_OK;  in this case *timePtr
+ *      will be set to the integer value equivalent to string.  If
+ *      string is improperly formed then TCL_ERROR is returned and
+ *      an error message will be left in interp->result.
+ *
+ * Side effects:
+ *      None.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+ParseTime(interp, string, timePtr)
+    Tcl_Interp *interp;
+    char *string;
+    unsigned long *timePtr;
+{
+    char *end, *p;
+    unsigned long  i;
+
+    /*
+     * Since some strtoul functions don't detect negative numbers, check
+     * in advance.
+     */
+    errno = 0;
+    for (p = (char *) string; isspace(UCHAR(*p)); p++) {
+        /* Empty loop body. */
+    }
+    if (*p == '+') {
+        p++;
+    }
+    i = strtoul(p, &end, 0);
+    if (end == p) {
+        goto badTime;
+    }
+    if (errno == ERANGE) {
+	interp->result = "integer value too large to represent";
+	Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
+		interp->result, (char *) NULL);
+	return TCL_ERROR;
+    }
+    while ((*end != '\0') && isspace(UCHAR(*end))) {
+        end++;
+    }
+    if (*end != '\0') {
+        goto badTime;
+    }
+
+    *timePtr = (time_t) i;
+    if (*timePtr != i) {
+        goto badTime;
+    }
+    return TCL_OK;
+
+  badTime:
+    Tcl_AppendResult (interp, "expected unsigned time but got \"", 
+                      string, "\"", (char *) NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * FormatClock --
+ *
+ *      Formats a time value based on seconds into a human readable
+ *	string.
+ *
+ * Results:
+ *      Standard Tcl result.
+ *
+ * Side effects:
+ *      None.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+FormatClock(interp, clockVal, useGMT, format)
+    Tcl_Interp *interp;			/* Current interpreter. */
+    unsigned long clockVal;	       	/* Time in seconds. */
+    int useGMT;				/* Boolean */
+    char *format;			/* Format string */
+{
+    struct tm *timeDataPtr;
+    Tcl_DString buffer;
+    int bufSize;
+#ifdef TCL_USE_TIMEZONE_VAR
+    int savedTimeZone;
+    char *savedTZEnv;
+#endif
+
+#ifdef HAVE_TZSET
+    /*
+     * Some systems forgot to call tzset in localtime, make sure its done.
+     */
+    static int  calledTzset = 0;
+
+    if (!calledTzset) {
+        tzset();
+        calledTzset = 1;
+    }
+#endif
+
+#ifdef TCL_USE_TIMEZONE_VAR
+    /*
+     * This is a horrible kludge for systems not having the timezone in
+     * struct tm.  No matter what was specified, they use the global time
+     * zone.  (Thanks Solaris).
+     */
+    if (useGMT) {
+        char *varValue;
+
+        varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
+        if (varValue != NULL) {
+	    savedTZEnv = strcpy(ckalloc(strlen(varValue) + 1), varValue);
+        } else {
+            savedTZEnv = NULL;
+	}
+        Tcl_SetVar2(interp, "env", "TZ", "GMT", TCL_GLOBAL_ONLY);
+        savedTimeZone = timezone;
+        timezone = 0;
+        tzset();
+    }
+#endif
+
+    if (useGMT) {
+        timeDataPtr = gmtime((time_t *) &clockVal);
+    } else {
+        timeDataPtr = localtime((time_t *) &clockVal);
+    }
+    
+    /*
+     * Format the time, increasing the buffer size until strftime succeeds.
+     */
+    bufSize = TCL_DSTRING_STATIC_SIZE - 1;
+    Tcl_DStringInit(&buffer);
+    Tcl_DStringSetLength(&buffer, bufSize);
+
+    while (strftime(buffer.string, (unsigned int) bufSize, format,
+	    timeDataPtr) == 0) {
+        bufSize *= 2;
+        Tcl_DStringSetLength(&buffer, bufSize);
+    }
+
+#ifdef TCL_USE_TIMEZONE_VAR
+    if (useGMT) {
+        if (savedTZEnv != NULL) {
+            Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY);
+            ckfree(savedTZEnv);
+        } else {
+            Tcl_UnsetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
+        }
+        timezone = savedTimeZone;
+        tzset();
+    }
+#endif
+
+    Tcl_DStringResult(interp, &buffer);
+    return TCL_OK;
+}
+

cde/programs/dtdocbook/tcl/tclEnv.c

@@ -0,0 +1,605 @@
+/* $XConsortium: tclEnv.c /main/2 1996/08/08 14:43:36 cde-hp $ */
+/* 
+ * tclEnv.c --
+ *
+ *	Tcl support for environment variables, including a setenv
+ *	procedure.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ *
+ * 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
+ */
+
+/*
+ * The putenv and setenv definitions below cause any system prototypes for
+ * those procedures to be ignored so that there won't be a clash when the
+ * versions in this file are compiled.
+ */
+
+#define putenv ignore_putenv
+#define setenv ignore_setenv
+#include "tclInt.h"
+#include "tclPort.h"
+#undef putenv
+#undef setenv
+
+/*
+ * The structure below is used to keep track of all of the interpereters
+ * for which we're managing the "env" array.  It's needed so that they
+ * can all be updated whenever an environment variable is changed
+ * anywhere.
+ */
+
+typedef struct EnvInterp {
+    Tcl_Interp *interp;		/* Interpreter for which we're managing
+				 * the env array. */
+    struct EnvInterp *nextPtr;	/* Next in list of all such interpreters,
+				 * or zero. */
+} EnvInterp;
+
+static EnvInterp *firstInterpPtr;
+				/* First in list of all managed interpreters,
+				 * or NULL if none. */
+
+static int environSize = 0;	/* Non-zero means that the all of the
+				 * environ-related information is malloc-ed
+				 * and the environ array itself has this
+				 * many total entries allocated to it (not
+				 * all may be in use at once).  Zero means
+				 * that the environment array is in its
+				 * original static state. */
+
+/*
+ * Declarations for local procedures defined in this file:
+ */
+
+static void		EnvExitProc _ANSI_ARGS_((ClientData clientData));
+static void		EnvInit _ANSI_ARGS_((void));
+static char *		EnvTraceProc _ANSI_ARGS_((ClientData clientData,
+			    Tcl_Interp *interp, char *name1, char *name2,
+			    int flags));
+static int		FindVariable _ANSI_ARGS_((CONST char *name,
+			    int *lengthPtr));
+void			TclSetEnv _ANSI_ARGS_((CONST char *name,
+			    CONST char *value));
+void			TclUnsetEnv _ANSI_ARGS_((CONST char *name));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetupEnv --
+ *
+ *	This procedure is invoked for an interpreter to make environment
+ *	variables accessible from that interpreter via the "env"
+ *	associative array.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The interpreter is added to a list of interpreters managed
+ *	by us, so that its view of envariables can be kept consistent
+ *	with the view in other interpreters.  If this is the first
+ *	call to Tcl_SetupEnv, then additional initialization happens,
+ *	such as copying the environment to dynamically-allocated space
+ *	for ease of management.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclSetupEnv(interp)
+    Tcl_Interp *interp;		/* Interpreter whose "env" array is to be
+				 * managed. */
+{
+    EnvInterp *eiPtr;
+    int i;
+
+    /*
+     * First, initialize our environment-related information, if
+     * necessary.
+     */
+
+    if (environSize == 0) {
+	EnvInit();
+    }
+
+    /*
+     * Next, add the interpreter to the list of those that we manage.
+     */
+
+    eiPtr = (EnvInterp *) ckalloc(sizeof(EnvInterp));
+    eiPtr->interp = interp;
+    eiPtr->nextPtr = firstInterpPtr;
+    firstInterpPtr = eiPtr;
+
+    /*
+     * Store the environment variable values into the interpreter's
+     * "env" array, and arrange for us to be notified on future
+     * writes and unsets to that array.
+     */
+
+    (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY);
+    for (i = 0; ; i++) {
+	char *p, *p2;
+
+	p = environ[i];
+	if (p == NULL) {
+	    break;
+	}
+	for (p2 = p; *p2 != '='; p2++) {
+	    /* Empty loop body. */
+	}
+	*p2 = 0;
+	(void) Tcl_SetVar2(interp, "env", p, p2+1, TCL_GLOBAL_ONLY);
+	*p2 = '=';
+    }
+    Tcl_TraceVar2(interp, "env", (char *) NULL,
+	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
+	    EnvTraceProc, (ClientData) NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FindVariable --
+ *
+ *	Locate the entry in environ for a given name.
+ *
+ * Results:
+ *	The return value is the index in environ of an entry with the
+ *	name "name", or -1 if there is no such entry.   The integer at
+ *	*lengthPtr is filled in with the length of name (if a matching
+ *	entry is found) or the length of the environ array (if no matching
+ *	entry is found).
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FindVariable(name, lengthPtr)
+    CONST char *name;		/* Name of desired environment variable. */
+    int *lengthPtr;		/* Used to return length of name (for
+				 * successful searches) or number of non-NULL
+				 * entries in environ (for unsuccessful
+				 * searches). */
+{
+    int i;
+    register CONST char *p1, *p2;
+
+    for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) {
+	for (p2 = name; *p2 == *p1; p1++, p2++) {
+	    /* NULL loop body. */
+	}
+	if ((*p1 == '=') && (*p2 == '\0')) {
+	    *lengthPtr = p2-name;
+	    return i;
+	}
+    }
+    *lengthPtr = i;
+    return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetEnv --
+ *
+ *	Get an environment variable or return NULL if the variable
+ *	doesn't exist.  This procedure is intended to be a
+ *	stand-in for the  UNIX "getenv" procedure so that applications
+ *	using that procedure will interface properly to Tcl.  To make
+ *	it a stand-in, the Makefile must define "TclGetEnv" to "getenv".
+ *
+ * Results:
+ *	ptr to value on success, NULL if error.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclGetEnv(name)
+    char *name;			/* Name of desired environment variable. */
+{
+    int i;
+    size_t len;
+
+    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')) {
+	    /*
+	     * The caller of this function should regard this
+	     * as static memory.
+	     */
+	    return &environ[i][len+1];
+	}
+    }
+
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetEnv --
+ *
+ *	Set an environment variable, replacing an existing value
+ *	or creating a new variable if there doesn't exist a variable
+ *	by the given name.  This procedure is intended to be a
+ *	stand-in for the  UNIX "setenv" procedure so that applications
+ *	using that procedure will interface properly to Tcl.  To make
+ *	it a stand-in, the Makefile must define "TclSetEnv" to "setenv".
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The environ array gets updated, as do all of the interpreters
+ *	that we manage.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclSetEnv(name, value)
+    CONST char *name;		/* Name of variable whose value is to be
+				 * set. */
+    CONST char *value;		/* New value for variable. */
+{
+    int index, length, nameLength;
+    char *p;
+    EnvInterp *eiPtr;
+
+    if (environSize == 0) {
+	EnvInit();
+    }
+
+    /*
+     * Figure out where the entry is going to go.  If the name doesn't
+     * already exist, enlarge the array if necessary to make room.  If
+     * the name exists, free its old entry.
+     */
+
+    index = FindVariable(name, &length);
+    if (index == -1) {
+	if ((length+2) > environSize) {
+	    char **newEnviron;
+
+	    newEnviron = (char **) ckalloc((unsigned)
+		    ((length+5) * sizeof(char *)));
+	    memcpy((VOID *) newEnviron, (VOID *) environ,
+		    length*sizeof(char *));
+	    ckfree((char *) environ);
+	    environ = newEnviron;
+	    environSize = length+5;
+	}
+	index = length;
+	environ[index+1] = NULL;
+	nameLength = strlen(name);
+    } else {
+	/*
+	 * Compare the new value to the existing value.  If they're
+	 * the same then quit immediately (e.g. don't rewrite the
+	 * value or propagate it to other interpreters).  Otherwise,
+	 * when there are N interpreters there will be N! propagations
+	 * of the same value among the interpreters.
+	 */
+
+	if (strcmp(value, environ[index]+length+1) == 0) {
+	    return;
+	}
+	ckfree(environ[index]);
+	nameLength = length;
+    }
+
+    /*
+     * Create a new entry and enter it into the table.
+     */
+
+    p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
+    environ[index] = p;
+    strcpy(p, name);
+    p += nameLength;
+    *p = '=';
+    strcpy(p+1, value);
+
+    /*
+     * Update all of the interpreters.
+     */
+
+    for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
+	(void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name,
+		p+1, TCL_GLOBAL_ONLY);
+    }
+
+    /*
+     * Update the system environment.
+     */
+
+    TclSetSystemEnv(name, value);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_PutEnv --
+ *
+ *	Set an environment variable.  Similar to setenv except that
+ *	the information is passed in a single string of the form
+ *	NAME=value, rather than as separate name strings.  This procedure
+ *	is intended to be a stand-in for the  UNIX "putenv" procedure
+ *	so that applications using that procedure will interface
+ *	properly to Tcl.  To make it a stand-in, the Makefile will
+ *	define "Tcl_PutEnv" to "putenv".
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The environ array gets updated, as do all of the interpreters
+ *	that we manage.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_PutEnv(string)
+    CONST char *string;		/* Info about environment variable in the
+				 * form NAME=value. */
+{
+    int nameLength;
+    char *name, *value;
+
+    if (string == NULL) {
+	return 0;
+    }
+
+    /*
+     * Separate the string into name and value parts, then call
+     * TclSetEnv to do all of the real work.
+     */
+
+    value = strchr(string, '=');
+    if (value == NULL) {
+	return 0;
+    }
+    nameLength = value - string;
+    if (nameLength == 0) {
+	return 0;
+    }
+    name = (char *) ckalloc((unsigned) nameLength+1);
+    memcpy(name, string, (size_t) nameLength);
+    name[nameLength] = 0;
+    TclSetEnv(name, value+1);
+    ckfree(name);
+    return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclUnsetEnv --
+ *
+ *	Remove an environment variable, updating the "env" arrays
+ *	in all interpreters managed by us.  This function is intended
+ *	to replace the UNIX "unsetenv" function (but to do this the
+ *	Makefile must be modified to redefine "TclUnsetEnv" to
+ *	"unsetenv".
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Interpreters are updated, as is environ.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclUnsetEnv(name)
+    CONST char *name;			/* Name of variable to remove. */
+{
+    int index, dummy;
+    char **envPtr;
+    EnvInterp *eiPtr;
+
+    if (environSize == 0) {
+	EnvInit();
+    }
+
+    /*
+     * Update the environ array.
+     */
+
+    index = FindVariable(name, &dummy);
+    if (index == -1) {
+	return;
+    }
+    ckfree(environ[index]);
+    for (envPtr = environ+index+1; ; envPtr++) {
+	envPtr[-1] = *envPtr;
+	if (*envPtr == NULL) {
+	    break;
+       }
+    }
+
+    /*
+     * Update all of the interpreters.
+     */
+
+    for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
+	(void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name,
+		TCL_GLOBAL_ONLY);
+    }
+
+    /*
+     * Update the system environment.
+     */
+
+    TclSetSystemEnv(name, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EnvTraceProc --
+ *
+ *	This procedure is invoked whenever an environment variable
+ *	is modified or deleted.  It propagates the change to the
+ *	"environ" array and to any other interpreters for whom
+ *	we're managing an "env" array.
+ *
+ * Results:
+ *	Always returns NULL to indicate success.
+ *
+ * Side effects:
+ *	Environment variable changes get propagated.  If the whole
+ *	"env" array is deleted, then we stop managing things for
+ *	this interpreter (usually this happens because the whole
+ *	interpreter is being deleted).
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static char *
+EnvTraceProc(clientData, interp, name1, name2, flags)
+    ClientData clientData;	/* Not used. */
+    Tcl_Interp *interp;		/* Interpreter whose "env" variable is
+				 * being modified. */
+    char *name1;		/* Better be "env". */
+    char *name2;		/* Name of variable being modified, or
+				 * NULL if whole array is being deleted. */
+    int flags;			/* Indicates what's happening. */
+{
+    /*
+     * First see if the whole "env" variable is being deleted.  If
+     * so, just forget about this interpreter.
+     */
+
+    if (name2 == NULL) {
+	register EnvInterp *eiPtr, *prevPtr;
+
+	if ((flags & (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED))
+		!= (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) {
+	    panic("EnvTraceProc called with confusing arguments");
+	}
+	eiPtr = firstInterpPtr;
+	if (eiPtr->interp == interp) {
+	    firstInterpPtr = eiPtr->nextPtr;
+	} else {
+	    for (prevPtr = eiPtr, eiPtr = eiPtr->nextPtr; ;
+		    prevPtr = eiPtr, eiPtr = eiPtr->nextPtr) {
+		if (eiPtr == NULL) {
+		    panic("EnvTraceProc couldn't find interpreter");
+		}
+		if (eiPtr->interp == interp) {
+		    prevPtr->nextPtr = eiPtr->nextPtr;
+		    break;
+		}
+	    }
+	}
+	ckfree((char *) eiPtr);
+	return NULL;
+    }
+
+    /*
+     * If a value is being set, call TclSetEnv to do all of the work.
+     */
+
+    if (flags & TCL_TRACE_WRITES) {
+	TclSetEnv(name2, Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY));
+    }
+
+    if (flags & TCL_TRACE_UNSETS) {
+	TclUnsetEnv(name2);
+    }
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EnvInit --
+ *
+ *	This procedure is called to initialize our management
+ *	of the environ array.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Environ gets copied to malloc-ed storage, so that in
+ *	the future we don't have to worry about which entries
+ *	are malloc-ed and which are static.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+EnvInit()
+{
+#ifdef MAC_TCL
+    environSize = TclMacCreateEnv();
+#else
+    char **newEnviron;
+    int i, length;
+
+    if (environSize != 0) {
+	return;
+    }
+    for (length = 0; environ[length] != NULL; length++) {
+	/* Empty loop body. */
+    }
+    environSize = length+5;
+    newEnviron = (char **) ckalloc((unsigned)
+		(environSize * sizeof(char *)));
+    for (i = 0; i < length; i++) {
+	newEnviron[i] = (char *) ckalloc((unsigned) (strlen(environ[i]) + 1));
+	strcpy(newEnviron[i], environ[i]);
+    }
+    newEnviron[length] = NULL;
+    environ = newEnviron;
+    Tcl_CreateExitHandler(EnvExitProc, (ClientData) NULL);
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EnvExitProc --
+ *
+ *	This procedure is called just before the process exits.  It
+ *	frees the memory associated with environment variables.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Memory is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+EnvExitProc(clientData)
+    ClientData clientData;		/* Not  used. */
+{
+    char **p;
+
+    for (p = environ; *p != NULL; p++) {
+	ckfree(*p);
+    }
+    ckfree((char *) environ);
+}

cde/programs/dtdocbook/tcl/tclFHandle.c

@@ -0,0 +1,255 @@
+/* $XConsortium: tclFHandle.c /main/2 1996/08/08 14:43:54 cde-hp $ */
+/* 
+ * tclFHandle.c --
+ *
+ *	This file contains functions for manipulating Tcl file handles.
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * 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
+ */
+
+#include "tcl.h"
+#include "tclPort.h"
+
+/*
+ * The FileHashKey structure is used to associate the OS file handle and type
+ * with the corresponding notifier data in a FileHandle.
+ */
+
+typedef struct FileHashKey {
+    int type;			/* File handle type. */
+    ClientData osHandle;	/* Platform specific OS file handle. */
+} FileHashKey;
+
+typedef struct FileHandle {
+    FileHashKey key;		/* Hash key for a given file. */
+    ClientData data;		/* Platform specific notifier data. */
+    Tcl_FileFreeProc *proc;	/* Callback to invoke when file is freed. */
+} FileHandle;
+
+/*
+ * Static variables used in this file:
+ */
+
+static Tcl_HashTable fileTable;	/* Hash table containing file handles. */
+static int initialized = 0;	/* 1 if this module has been initialized. */
+
+/*
+ * Static procedures used in this file:
+ */
+
+static void 		FileExitProc _ANSI_ARGS_((ClientData clientData));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetFile --
+ *
+ *	This function retrieves the file handle associated with a
+ *	platform specific file handle of the given type.  It creates
+ *	a new file handle if needed.
+ *
+ * Results:
+ *	Returns the file handle associated with the file descriptor.
+ *
+ * Side effects:
+ *	Initializes the file handle table if necessary.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_File
+Tcl_GetFile(osHandle, type)
+    ClientData osHandle;	/* Platform specific file handle. */
+    int type;			/* Type of file handle. */
+{
+    FileHashKey key;
+    Tcl_HashEntry *entryPtr;
+    int new;
+
+    if (!initialized) {
+	Tcl_InitHashTable(&fileTable, sizeof(FileHashKey)/sizeof(int));
+	Tcl_CreateExitHandler(FileExitProc, 0);
+	initialized = 1;
+    }
+    key.osHandle = osHandle;
+    key.type = type;
+    entryPtr = Tcl_CreateHashEntry(&fileTable, (char *) &key, &new);
+    if (new) {
+	FileHandle *newHandlePtr;
+	newHandlePtr = (FileHandle *) ckalloc(sizeof(FileHandle));
+	newHandlePtr->key = key;
+	newHandlePtr->data = NULL;
+	newHandlePtr->proc = NULL;
+	Tcl_SetHashValue(entryPtr, newHandlePtr);
+    }
+    
+    return (Tcl_File) Tcl_GetHashValue(entryPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FreeFile --
+ *
+ *	Deallocates an entry in the file handle table.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FreeFile(handle)
+    Tcl_File handle;
+{
+    Tcl_HashEntry *entryPtr;
+    FileHandle *handlePtr = (FileHandle *) handle;
+
+    /*
+     * Invoke free procedure, then delete the handle.
+     */
+
+    if (handlePtr->proc) {
+	(*handlePtr->proc)(handlePtr->data);
+    }
+
+    entryPtr = Tcl_FindHashEntry(&fileTable, (char *) &handlePtr->key);
+    if (entryPtr) {
+	Tcl_DeleteHashEntry(entryPtr);
+	ckfree((char *) handlePtr);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetFileInfo --
+ *
+ *	This function retrieves the platform specific file data and
+ *	type from the file handle.
+ *
+ * Results:
+ *	If typePtr is not NULL, sets *typePtr to the type of the file.
+ *	Returns the platform specific file data.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_GetFileInfo(handle, typePtr)
+    Tcl_File handle;
+    int *typePtr;
+{
+    FileHandle *handlePtr = (FileHandle *) handle;
+
+    if (typePtr) {
+	*typePtr = handlePtr->key.type;
+    }
+    return handlePtr->key.osHandle;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetNotifierData --
+ *
+ *	This function is used by the notifier to associate platform
+ *	specific notifier information and a deletion procedure with
+ *	a file handle.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Updates the data and delProc slots in the file handle.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetNotifierData(handle, proc, data)
+    Tcl_File handle;
+    Tcl_FileFreeProc *proc;
+    ClientData data;
+{
+    FileHandle *handlePtr = (FileHandle *) handle;
+    handlePtr->proc = proc;
+    handlePtr->data = data;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetNotifierData --
+ *
+ *	This function is used by the notifier to retrieve the platform
+ *	specific notifier information associated with a file handle.
+ *
+ * Results:
+ *	Returns the data stored in a file handle by a previous call to
+ *	Tcl_SetNotifierData, and places a pointer to the free proc
+ *	in the location referred to by procPtr.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_GetNotifierData(handle, procPtr)
+    Tcl_File handle;
+    Tcl_FileFreeProc **procPtr;
+{
+    FileHandle *handlePtr = (FileHandle *) handle;
+    if (procPtr != NULL) {
+	*procPtr = handlePtr->proc;
+    }
+    return handlePtr->data;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileExitProc --
+ *
+ *	This function an exit handler that frees any memory allocated
+ *	for the file handle table.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Cleans up the file handle table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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);
+}

cde/programs/dtdocbook/tcl/tclGet.c

@@ -0,0 +1,233 @@
+/* $XConsortium: tclGet.c /main/2 1996/08/08 14:44:07 cde-hp $ */
+/* 
+ * tclGet.c --
+ *
+ *	This file contains procedures to convert strings into
+ *	other forms, like integers or floating-point numbers or
+ *	booleans, doing syntax checking along the way.
+ *
+ * Copyright (c) 1990-1993 The Regents of the University of California.
+ * Copyright (c) 1994-1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclGet.c 1.24 96/02/15 11:42:47
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetInt --
+ *
+ *	Given a string, produce the corresponding integer value.
+ *
+ * Results:
+ *	The return value is normally TCL_OK;  in this case *intPtr
+ *	will be set to the integer value equivalent to string.  If
+ *	string is improperly formed then TCL_ERROR is returned and
+ *	an error message will be left in interp->result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetInt(interp, string, intPtr)
+    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
+    char *string;		/* String containing a (possibly signed)
+				 * integer in a form acceptable to strtol. */
+    int *intPtr;		/* Place to store converted result. */
+{
+    char *end, *p;
+    int i;
+
+    /*
+     * Note: use strtoul instead of strtol for integer conversions
+     * to allow full-size unsigned numbers, but don't depend on strtoul
+     * to handle sign characters;  it won't in some implementations.
+     */
+
+    errno = 0;
+    for (p = string; isspace(UCHAR(*p)); p++) {
+	/* Empty loop body. */
+    }
+    if (*p == '-') {
+	p++;
+	i = -(int)strtoul(p, &end, 0);
+    } else if (*p == '+') {
+	p++;
+	i = strtoul(p, &end, 0);
+    } else {
+	i = strtoul(p, &end, 0);
+    }
+    if (end == p) {
+	badInteger:
+        if (interp != (Tcl_Interp *) NULL) {
+            Tcl_AppendResult(interp, "expected integer but got \"", string,
+                    "\"", (char *) NULL);
+        }
+	return TCL_ERROR;
+    }
+    if (errno == ERANGE) {
+        if (interp != (Tcl_Interp *) NULL) {
+            interp->result = "integer value too large to represent";
+            Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
+                    interp->result, (char *) NULL);
+        }
+	return TCL_ERROR;
+    }
+    while ((*end != '\0') && isspace(UCHAR(*end))) {
+	end++;
+    }
+    if (*end != 0) {
+	goto badInteger;
+    }
+    *intPtr = i;
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetDouble --
+ *
+ *	Given a string, produce the corresponding double-precision
+ *	floating-point value.
+ *
+ * Results:
+ *	The return value is normally TCL_OK;  in this case *doublePtr
+ *	will be set to the double-precision value equivalent to string.
+ *	If string is improperly formed then TCL_ERROR is returned and
+ *	an error message will be left in interp->result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetDouble(interp, string, doublePtr)
+    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
+    char *string;		/* String containing a floating-point number
+				 * in a form acceptable to strtod. */
+    double *doublePtr;		/* Place to store converted result. */
+{
+    char *end;
+    double d;
+
+    errno = 0;
+    d = strtod(string, &end);
+    if (end == string) {
+	badDouble:
+        if (interp != (Tcl_Interp *) NULL) {
+            Tcl_AppendResult(interp,
+                    "expected floating-point number but got \"",
+                    string, "\"", (char *) NULL);
+        }
+	return TCL_ERROR;
+    }
+    if (errno != 0) {
+        if (interp != (Tcl_Interp *) NULL) {
+            TclExprFloatError(interp, d);
+        }
+	return TCL_ERROR;
+    }
+    while ((*end != 0) && isspace(UCHAR(*end))) {
+	end++;
+    }
+    if (*end != 0) {
+	goto badDouble;
+    }
+    *doublePtr = d;
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetBoolean --
+ *
+ *	Given a string, return a 0/1 boolean value corresponding
+ *	to the string.
+ *
+ * Results:
+ *	The return value is normally TCL_OK;  in this case *boolPtr
+ *	will be set to the 0/1 value equivalent to string.  If
+ *	string is improperly formed then TCL_ERROR is returned and
+ *	an error message will be left in interp->result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetBoolean(interp, string, boolPtr)
+    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
+    char *string;		/* String containing a boolean number
+				 * specified either as 1/0 or true/false or
+				 * yes/no. */
+    int *boolPtr;		/* Place to store converted result, which
+				 * will be 0 or 1. */
+{
+    int i;
+    char lowerCase[10], c;
+    size_t length;
+
+    /*
+     * Convert the input string to all lower-case.
+     */
+
+    for (i = 0; i < 9; i++) {
+	c = string[i];
+	if (c == 0) {
+	    break;
+	}
+	if ((c >= 'A') && (c <= 'Z')) {
+	    c += (char) ('a' - 'A');
+	}
+	lowerCase[i] = c;
+    }
+    lowerCase[i] = 0;
+
+    length = strlen(lowerCase);
+    c = lowerCase[0];
+    if ((c == '0') && (lowerCase[1] == '\0')) {
+	*boolPtr = 0;
+    } else if ((c == '1') && (lowerCase[1] == '\0')) {
+	*boolPtr = 1;
+    } else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) {
+	*boolPtr = 1;
+    } else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) {
+	*boolPtr = 0;
+    } else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) {
+	*boolPtr = 1;
+    } else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) {
+	*boolPtr = 0;
+    } else if ((c == 'o') && (length >= 2)) {
+	if (strncmp(lowerCase, "on", length) == 0) {
+	    *boolPtr = 1;
+	} else if (strncmp(lowerCase, "off", length) == 0) {
+	    *boolPtr = 0;
+	} else {
+	    goto badBoolean;
+	}
+    } else {
+	badBoolean:
+        if (interp != (Tcl_Interp *) NULL) {
+            Tcl_AppendResult(interp, "expected boolean value but got \"",
+                    string, "\"", (char *) NULL);
+        }
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}

cde/programs/dtdocbook/tcl/tclHash.c

@@ -0,0 +1,922 @@
+/* $XConsortium: tclHash.c /main/2 1996/08/08 14:44:13 cde-hp $ */
+/* 
+ * tclHash.c --
+ *
+ *	Implementation of in-memory hash tables for Tcl and Tcl-based
+ *	applications.
+ *
+ * Copyright (c) 1991-1993 The Regents of the University of California.
+ * Copyright (c) 1994 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclHash.c 1.15 96/02/15 11:50:23
+ */
+
+#include "tclInt.h"
+
+/*
+ * When there are this many entries per bucket, on average, rebuild
+ * the hash table to make it larger.
+ */
+
+#define REBUILD_MULTIPLIER	3
+
+
+/*
+ * The following macro takes a preliminary integer hash value and
+ * produces an index into a hash tables bucket list.  The idea is
+ * to make it so that preliminary values that are arbitrarily similar
+ * will end up in different buckets.  The hash function was taken
+ * from a random-number generator.
+ */
+
+#define RANDOM_INDEX(tablePtr, i) \
+    (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask)
+
+/*
+ * Procedure prototypes for static procedures in this file:
+ */
+
+static Tcl_HashEntry *	ArrayFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+			    char *key));
+static Tcl_HashEntry *	ArrayCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+			    char *key, int *newPtr));
+static Tcl_HashEntry *	BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+			    char *key));
+static Tcl_HashEntry *	BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+			    char *key, int *newPtr));
+static unsigned int	HashString _ANSI_ARGS_((char *string));
+static void		RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr));
+static Tcl_HashEntry *	StringFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+			    char *key));
+static Tcl_HashEntry *	StringCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+			    char *key, int *newPtr));
+static Tcl_HashEntry *	OneWordFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+			    char *key));
+static Tcl_HashEntry *	OneWordCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+			    char *key, int *newPtr));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitHashTable --
+ *
+ *	Given storage for a hash table, set up the fields to prepare
+ *	the hash table for use.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	TablePtr is now ready to be passed to Tcl_FindHashEntry and
+ *	Tcl_CreateHashEntry.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_InitHashTable(tablePtr, keyType)
+    register Tcl_HashTable *tablePtr;	/* Pointer to table record, which
+					 * is supplied by the caller. */
+    int keyType;			/* Type of keys to use in table:
+					 * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
+					 * or an integer >= 2. */
+{
+    tablePtr->buckets = tablePtr->staticBuckets;
+    tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
+    tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
+    tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
+    tablePtr->numEntries = 0;
+    tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
+    tablePtr->downShift = 28;
+    tablePtr->mask = 3;
+    tablePtr->keyType = keyType;
+    if (keyType == TCL_STRING_KEYS) {
+	tablePtr->findProc = StringFind;
+	tablePtr->createProc = StringCreate;
+    } else if (keyType == TCL_ONE_WORD_KEYS) {
+	tablePtr->findProc = OneWordFind;
+	tablePtr->createProc = OneWordCreate;
+    } else {
+	tablePtr->findProc = ArrayFind;
+	tablePtr->createProc = ArrayCreate;
+    };
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteHashEntry --
+ *
+ *	Remove a single entry from a hash table.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The entry given by entryPtr is deleted from its table and
+ *	should never again be used by the caller.  It is up to the
+ *	caller to free the clientData field of the entry, if that
+ *	is relevant.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteHashEntry(entryPtr)
+    Tcl_HashEntry *entryPtr;
+{
+    register Tcl_HashEntry *prevPtr;
+
+    if (*entryPtr->bucketPtr == entryPtr) {
+	*entryPtr->bucketPtr = entryPtr->nextPtr;
+    } else {
+	for (prevPtr = *entryPtr->bucketPtr; ; prevPtr = prevPtr->nextPtr) {
+	    if (prevPtr == NULL) {
+		panic("malformed bucket chain in Tcl_DeleteHashEntry");
+	    }
+	    if (prevPtr->nextPtr == entryPtr) {
+		prevPtr->nextPtr = entryPtr->nextPtr;
+		break;
+	    }
+	}
+    }
+    entryPtr->tablePtr->numEntries--;
+    ckfree((char *) entryPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteHashTable --
+ *
+ *	Free up everything associated with a hash table except for
+ *	the record for the table itself.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The hash table is no longer useable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteHashTable(tablePtr)
+    register Tcl_HashTable *tablePtr;		/* Table to delete. */
+{
+    register Tcl_HashEntry *hPtr, *nextPtr;
+    int i;
+
+    /*
+     * Free up all the entries in the table.
+     */
+
+    for (i = 0; i < tablePtr->numBuckets; i++) {
+	hPtr = tablePtr->buckets[i];
+	while (hPtr != NULL) {
+	    nextPtr = hPtr->nextPtr;
+	    ckfree((char *) hPtr);
+	    hPtr = nextPtr;
+	}
+    }
+
+    /*
+     * Free up the bucket array, if it was dynamically allocated.
+     */
+
+    if (tablePtr->buckets != tablePtr->staticBuckets) {
+	ckfree((char *) tablePtr->buckets);
+    }
+
+    /*
+     * Arrange for panics if the table is used again without
+     * re-initialization.
+     */
+
+    tablePtr->findProc = BogusFind;
+    tablePtr->createProc = BogusCreate;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FirstHashEntry --
+ *
+ *	Locate the first entry in a hash table and set up a record
+ *	that can be used to step through all the remaining entries
+ *	of the table.
+ *
+ * Results:
+ *	The return value is a pointer to the first entry in tablePtr,
+ *	or NULL if tablePtr has no entries in it.  The memory at
+ *	*searchPtr is initialized so that subsequent calls to
+ *	Tcl_NextHashEntry will return all of the entries in the table,
+ *	one at a time.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_HashEntry *
+Tcl_FirstHashEntry(tablePtr, searchPtr)
+    Tcl_HashTable *tablePtr;		/* Table to search. */
+    Tcl_HashSearch *searchPtr;		/* Place to store information about
+					 * progress through the table. */
+{
+    searchPtr->tablePtr = tablePtr;
+    searchPtr->nextIndex = 0;
+    searchPtr->nextEntryPtr = NULL;
+    return Tcl_NextHashEntry(searchPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_NextHashEntry --
+ *
+ *	Once a hash table enumeration has been initiated by calling
+ *	Tcl_FirstHashEntry, this procedure may be called to return
+ *	successive elements of the table.
+ *
+ * Results:
+ *	The return value is the next entry in the hash table being
+ *	enumerated, or NULL if the end of the table is reached.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_HashEntry *
+Tcl_NextHashEntry(searchPtr)
+    register Tcl_HashSearch *searchPtr;	/* Place to store information about
+					 * progress through the table.  Must
+					 * have been initialized by calling
+					 * Tcl_FirstHashEntry. */
+{
+    Tcl_HashEntry *hPtr;
+
+    while (searchPtr->nextEntryPtr == NULL) {
+	if (searchPtr->nextIndex >= searchPtr->tablePtr->numBuckets) {
+	    return NULL;
+	}
+	searchPtr->nextEntryPtr =
+		searchPtr->tablePtr->buckets[searchPtr->nextIndex];
+	searchPtr->nextIndex++;
+    }
+    hPtr = searchPtr->nextEntryPtr;
+    searchPtr->nextEntryPtr = hPtr->nextPtr;
+    return hPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_HashStats --
+ *
+ *	Return statistics describing the layout of the hash table
+ *	in its hash buckets.
+ *
+ * Results:
+ *	The return value is a malloc-ed string containing information
+ *	about tablePtr.  It is the caller's responsibility to free
+ *	this string.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_HashStats(tablePtr)
+    Tcl_HashTable *tablePtr;		/* Table for which to produce stats. */
+{
+#define NUM_COUNTERS 10
+    int count[NUM_COUNTERS], overflow, i, j;
+    double average, tmp;
+    register Tcl_HashEntry *hPtr;
+    char *result, *p;
+
+    /*
+     * Compute a histogram of bucket usage.
+     */
+
+    for (i = 0; i < NUM_COUNTERS; i++) {
+	count[i] = 0;
+    }
+    overflow = 0;
+    average = 0.0;
+    for (i = 0; i < tablePtr->numBuckets; i++) {
+	j = 0;
+	for (hPtr = tablePtr->buckets[i]; hPtr != NULL; hPtr = hPtr->nextPtr) {
+	    j++;
+	}
+	if (j < NUM_COUNTERS) {
+	    count[j]++;
+	} else {
+	    overflow++;
+	}
+	tmp = j;
+	average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
+    }
+
+    /*
+     * Print out the histogram and a few other pieces of information.
+     */
+
+    result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
+    sprintf(result, "%d entries in table, %d buckets\n",
+	    tablePtr->numEntries, tablePtr->numBuckets);
+    p = result + strlen(result);
+    for (i = 0; i < NUM_COUNTERS; i++) {
+	sprintf(p, "number of buckets with %d entries: %d\n",
+		i, count[i]);
+	p += strlen(p);
+    }
+    sprintf(p, "number of buckets with %d or more entries: %d\n",
+	    NUM_COUNTERS, overflow);
+    p += strlen(p);
+    sprintf(p, "average search distance for entry: %.1f", average);
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * HashString --
+ *
+ *	Compute a one-word summary of a text string, which can be
+ *	used to generate a hash index.
+ *
+ * Results:
+ *	The return value is a one-word summary of the information in
+ *	string.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static unsigned int
+HashString(string)
+    register char *string;	/* String from which to compute hash value. */
+{
+    register unsigned int result;
+    register int c;
+
+    /*
+     * I tried a zillion different hash functions and asked many other
+     * people for advice.  Many people had their own favorite functions,
+     * all different, but no-one had much idea why they were good ones.
+     * I chose the one below (multiply by 9 and add new character)
+     * because of the following reasons:
+     *
+     * 1. Multiplying by 10 is perfect for keys that are decimal strings,
+     *    and multiplying by 9 is just about as good.
+     * 2. Times-9 is (shift-left-3) plus (old).  This means that each
+     *    character's bits hang around in the low-order bits of the
+     *    hash value for ever, plus they spread fairly rapidly up to
+     *    the high-order bits to fill out the hash value.  This seems
+     *    works well both for decimal and non-decimal strings.
+     */
+
+    result = 0;
+    while (1) {
+	c = *string;
+	string++;
+	if (c == 0) {
+	    break;
+	}
+	result += (result<<3) + c;
+    }
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringFind --
+ *
+ *	Given a hash table with string keys, and a string key, find
+ *	the entry with a matching key.
+ *
+ * Results:
+ *	The return value is a token for the matching entry in the
+ *	hash table, or NULL if there was no matching entry.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashEntry *
+StringFind(tablePtr, key)
+    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
+    char *key;			/* Key to use to find matching entry. */
+{
+    register Tcl_HashEntry *hPtr;
+    register char *p1, *p2;
+    int index;
+
+    index = HashString(key) & tablePtr->mask;
+
+    /*
+     * Search all of the entries in the appropriate bucket.
+     */
+
+    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+	    hPtr = hPtr->nextPtr) {
+	for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) {
+	    if (*p1 != *p2) {
+		break;
+	    }
+	    if (*p1 == '\0') {
+		return hPtr;
+	    }
+	}
+    }
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringCreate --
+ *
+ *	Given a hash table with string keys, and a string key, find
+ *	the entry with a matching key.  If there is no matching entry,
+ *	then create a new entry that does match.
+ *
+ * Results:
+ *	The return value is a pointer to the matching entry.  If this
+ *	is a newly-created entry, then *newPtr will be set to a non-zero
+ *	value;  otherwise *newPtr will be set to 0.  If this is a new
+ *	entry the value stored in the entry will initially be 0.
+ *
+ * Side effects:
+ *	A new entry may be added to the hash table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashEntry *
+StringCreate(tablePtr, key, newPtr)
+    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
+    char *key;			/* Key to use to find or create matching
+				 * entry. */
+    int *newPtr;		/* Store info here telling whether a new
+				 * entry was created. */
+{
+    register Tcl_HashEntry *hPtr;
+    register char *p1, *p2;
+    int index;
+
+    index = HashString(key) & tablePtr->mask;
+
+    /*
+     * Search all of the entries in this bucket.
+     */
+
+    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+	    hPtr = hPtr->nextPtr) {
+	for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) {
+	    if (*p1 != *p2) {
+		break;
+	    }
+	    if (*p1 == '\0') {
+		*newPtr = 0;
+		return hPtr;
+	    }
+	}
+    }
+
+    /*
+     * Entry not found.  Add a new one to the bucket.
+     */
+
+    *newPtr = 1;
+    hPtr = (Tcl_HashEntry *) ckalloc((unsigned)
+	    (sizeof(Tcl_HashEntry) + strlen(key) - (sizeof(hPtr->key) -1)));
+    hPtr->tablePtr = tablePtr;
+    hPtr->bucketPtr = &(tablePtr->buckets[index]);
+    hPtr->nextPtr = *hPtr->bucketPtr;
+    hPtr->clientData = 0;
+    strcpy(hPtr->key.string, key);
+    *hPtr->bucketPtr = hPtr;
+    tablePtr->numEntries++;
+
+    /*
+     * If the table has exceeded a decent size, rebuild it with many
+     * more buckets.
+     */
+
+    if (tablePtr->numEntries >= tablePtr->rebuildSize) {
+	RebuildTable(tablePtr);
+    }
+    return hPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * OneWordFind --
+ *
+ *	Given a hash table with one-word keys, and a one-word key, find
+ *	the entry with a matching key.
+ *
+ * Results:
+ *	The return value is a token for the matching entry in the
+ *	hash table, or NULL if there was no matching entry.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashEntry *
+OneWordFind(tablePtr, key)
+    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
+    register char *key;		/* Key to use to find matching entry. */
+{
+    register Tcl_HashEntry *hPtr;
+    int index;
+
+    index = RANDOM_INDEX(tablePtr, key);
+
+    /*
+     * Search all of the entries in the appropriate bucket.
+     */
+
+    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+	    hPtr = hPtr->nextPtr) {
+	if (hPtr->key.oneWordValue == key) {
+	    return hPtr;
+	}
+    }
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * OneWordCreate --
+ *
+ *	Given a hash table with one-word keys, and a one-word key, find
+ *	the entry with a matching key.  If there is no matching entry,
+ *	then create a new entry that does match.
+ *
+ * Results:
+ *	The return value is a pointer to the matching entry.  If this
+ *	is a newly-created entry, then *newPtr will be set to a non-zero
+ *	value;  otherwise *newPtr will be set to 0.  If this is a new
+ *	entry the value stored in the entry will initially be 0.
+ *
+ * Side effects:
+ *	A new entry may be added to the hash table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashEntry *
+OneWordCreate(tablePtr, key, newPtr)
+    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
+    register char *key;		/* Key to use to find or create matching
+				 * entry. */
+    int *newPtr;		/* Store info here telling whether a new
+				 * entry was created. */
+{
+    register Tcl_HashEntry *hPtr;
+    int index;
+
+    index = RANDOM_INDEX(tablePtr, key);
+
+    /*
+     * Search all of the entries in this bucket.
+     */
+
+    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+	    hPtr = hPtr->nextPtr) {
+	if (hPtr->key.oneWordValue == key) {
+	    *newPtr = 0;
+	    return hPtr;
+	}
+    }
+
+    /*
+     * Entry not found.  Add a new one to the bucket.
+     */
+
+    *newPtr = 1;
+    hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry));
+    hPtr->tablePtr = tablePtr;
+    hPtr->bucketPtr = &(tablePtr->buckets[index]);
+    hPtr->nextPtr = *hPtr->bucketPtr;
+    hPtr->clientData = 0;
+    hPtr->key.oneWordValue = key;
+    *hPtr->bucketPtr = hPtr;
+    tablePtr->numEntries++;
+
+    /*
+     * If the table has exceeded a decent size, rebuild it with many
+     * more buckets.
+     */
+
+    if (tablePtr->numEntries >= tablePtr->rebuildSize) {
+	RebuildTable(tablePtr);
+    }
+    return hPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayFind --
+ *
+ *	Given a hash table with array-of-int keys, and a key, find
+ *	the entry with a matching key.
+ *
+ * Results:
+ *	The return value is a token for the matching entry in the
+ *	hash table, or NULL if there was no matching entry.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashEntry *
+ArrayFind(tablePtr, key)
+    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
+    char *key;			/* Key to use to find matching entry. */
+{
+    register Tcl_HashEntry *hPtr;
+    int *arrayPtr = (int *) key;
+    register int *iPtr1, *iPtr2;
+    int index, count;
+
+    for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr;
+	    count > 0; count--, iPtr1++) {
+	index += *iPtr1;
+    }
+    index = RANDOM_INDEX(tablePtr, index);
+
+    /*
+     * Search all of the entries in the appropriate bucket.
+     */
+
+    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+	    hPtr = hPtr->nextPtr) {
+	for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words,
+		count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
+	    if (count == 0) {
+		return hPtr;
+	    }
+	    if (*iPtr1 != *iPtr2) {
+		break;
+	    }
+	}
+    }
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayCreate --
+ *
+ *	Given a hash table with one-word keys, and a one-word key, find
+ *	the entry with a matching key.  If there is no matching entry,
+ *	then create a new entry that does match.
+ *
+ * Results:
+ *	The return value is a pointer to the matching entry.  If this
+ *	is a newly-created entry, then *newPtr will be set to a non-zero
+ *	value;  otherwise *newPtr will be set to 0.  If this is a new
+ *	entry the value stored in the entry will initially be 0.
+ *
+ * Side effects:
+ *	A new entry may be added to the hash table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashEntry *
+ArrayCreate(tablePtr, key, newPtr)
+    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
+    register char *key;		/* Key to use to find or create matching
+				 * entry. */
+    int *newPtr;		/* Store info here telling whether a new
+				 * entry was created. */
+{
+    register Tcl_HashEntry *hPtr;
+    int *arrayPtr = (int *) key;
+    register int *iPtr1, *iPtr2;
+    int index, count;
+
+    for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr;
+	    count > 0; count--, iPtr1++) {
+	index += *iPtr1;
+    }
+    index = RANDOM_INDEX(tablePtr, index);
+
+    /*
+     * Search all of the entries in the appropriate bucket.
+     */
+
+    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+	    hPtr = hPtr->nextPtr) {
+	for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words,
+		count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
+	    if (count == 0) {
+		*newPtr = 0;
+		return hPtr;
+	    }
+	    if (*iPtr1 != *iPtr2) {
+		break;
+	    }
+	}
+    }
+
+    /*
+     * Entry not found.  Add a new one to the bucket.
+     */
+
+    *newPtr = 1;
+    hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)
+	    + (tablePtr->keyType*sizeof(int)) - 4));
+    hPtr->tablePtr = tablePtr;
+    hPtr->bucketPtr = &(tablePtr->buckets[index]);
+    hPtr->nextPtr = *hPtr->bucketPtr;
+    hPtr->clientData = 0;
+    for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, count = tablePtr->keyType;
+	    count > 0; count--, iPtr1++, iPtr2++) {
+	*iPtr2 = *iPtr1;
+    }
+    *hPtr->bucketPtr = hPtr;
+    tablePtr->numEntries++;
+
+    /*
+     * If the table has exceeded a decent size, rebuild it with many
+     * more buckets.
+     */
+
+    if (tablePtr->numEntries >= tablePtr->rebuildSize) {
+	RebuildTable(tablePtr);
+    }
+    return hPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BogusFind --
+ *
+ *	This procedure is invoked when an Tcl_FindHashEntry is called
+ *	on a table that has been deleted.
+ *
+ * Results:
+ *	If panic returns (which it shouldn't) this procedure returns
+ *	NULL.
+ *
+ * Side effects:
+ *	Generates a panic.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static Tcl_HashEntry *
+BogusFind(tablePtr, key)
+    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
+    char *key;			/* Key to use to find matching entry. */
+{
+    panic("called Tcl_FindHashEntry on deleted table");
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BogusCreate --
+ *
+ *	This procedure is invoked when an Tcl_CreateHashEntry is called
+ *	on a table that has been deleted.
+ *
+ * Results:
+ *	If panic returns (which it shouldn't) this procedure returns
+ *	NULL.
+ *
+ * Side effects:
+ *	Generates a panic.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static Tcl_HashEntry *
+BogusCreate(tablePtr, key, newPtr)
+    Tcl_HashTable *tablePtr;	/* Table in which to lookup entry. */
+    char *key;			/* Key to use to find or create matching
+				 * entry. */
+    int *newPtr;		/* Store info here telling whether a new
+				 * entry was created. */
+{
+    panic("called Tcl_CreateHashEntry on deleted table");
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RebuildTable --
+ *
+ *	This procedure is invoked when the ratio of entries to hash
+ *	buckets becomes too large.  It creates a new table with a
+ *	larger bucket array and moves all of the entries into the
+ *	new table.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Memory gets reallocated and entries get re-hashed to new
+ *	buckets.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+RebuildTable(tablePtr)
+    register Tcl_HashTable *tablePtr;	/* Table to enlarge. */
+{
+    int oldSize, count, index;
+    Tcl_HashEntry **oldBuckets;
+    register Tcl_HashEntry **oldChainPtr, **newChainPtr;
+    register Tcl_HashEntry *hPtr;
+
+    oldSize = tablePtr->numBuckets;
+    oldBuckets = tablePtr->buckets;
+
+    /*
+     * Allocate and initialize the new bucket array, and set up
+     * hashing constants for new array size.
+     */
+
+    tablePtr->numBuckets *= 4;
+    tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned)
+	    (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)));
+    for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
+	    count > 0; count--, newChainPtr++) {
+	*newChainPtr = NULL;
+    }
+    tablePtr->rebuildSize *= 4;
+    tablePtr->downShift -= 2;
+    tablePtr->mask = (tablePtr->mask << 2) + 3;
+
+    /*
+     * Rehash all of the existing entries into the new bucket array.
+     */
+
+    for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) {
+	for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) {
+	    *oldChainPtr = hPtr->nextPtr;
+	    if (tablePtr->keyType == TCL_STRING_KEYS) {
+		index = HashString(hPtr->key.string) & tablePtr->mask;
+	    } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
+		index = RANDOM_INDEX(tablePtr, hPtr->key.oneWordValue);
+	    } else {
+		register int *iPtr;
+		int count;
+
+		for (index = 0, count = tablePtr->keyType,
+			iPtr = hPtr->key.words; count > 0; count--, iPtr++) {
+		    index += *iPtr;
+		}
+		index = RANDOM_INDEX(tablePtr, index);
+	    }
+	    hPtr->bucketPtr = &(tablePtr->buckets[index]);
+	    hPtr->nextPtr = *hPtr->bucketPtr;
+	    *hPtr->bucketPtr = hPtr;
+	}
+    }
+
+    /*
+     * Free up the old bucket array, if it was dynamically allocated.
+     */
+
+    if (oldBuckets != tablePtr->staticBuckets) {
+	ckfree((char *) oldBuckets);
+    }
+}

cde/programs/dtdocbook/tcl/tclIOSock.c

@@ -0,0 +1,97 @@
+/* $XConsortium: tclIOSock.c /main/2 1996/08/08 14:44:39 cde-hp $ */
+/* 
+ * tclIOSock.c --
+ *
+ *	Common routines used by all socket based channel types.
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclIOSock.c 1.16 96/03/12 07:04:33
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSockGetPort --
+ *
+ *	Maps from a string, which could be a service name, to a port.
+ *	Used by socket creation code to get port numbers and resolve
+ *	registered service names to port numbers.
+ *
+ * Results:
+ *	A standard Tcl result.  On success, the port number is
+ *	returned in portPtr. On failure, an error message is left in
+ *	interp->result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclSockGetPort(interp, string, proto, portPtr)
+    Tcl_Interp *interp;
+    char *string;		/* Integer or service name */
+    char *proto;		/* "tcp" or "udp", typically */
+    int *portPtr;		/* Return port number */
+{
+    struct servent *sp = getservbyname(string, proto);    
+    if (sp != NULL) {
+	*portPtr = ntohs((unsigned short) sp->s_port);
+	return TCL_OK;
+    }
+    if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    if (*portPtr > 0xFFFF) {
+        Tcl_AppendResult(interp, "couldn't open socket: port number too high",
+                (char *) NULL);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSockMinimumBuffers --
+ *
+ *	Ensure minimum buffer sizes (non zero).
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	Sets SO_SNDBUF and SO_RCVBUF sizes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclSockMinimumBuffers(sock, size)
+    int sock;			/* Socket file descriptor */
+    int size;			/* Minimum buffer size */
+{
+    int current;
+    int len = sizeof(int);
+
+    getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *) &current, &len);
+    if (current < size) {
+	len = sizeof(int);
+	setsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *) &size, len);
+    }
+    len = sizeof(int);
+    getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *) &current, &len);
+    if (current < size) {
+	len = sizeof(int);
+	setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *) &size, len);
+    }
+    return TCL_OK;
+}

cde/programs/dtdocbook/tcl/tclLink.c

@@ -0,0 +1,391 @@
+/* $XConsortium: tclLink.c /main/2 1996/08/08 14:45:07 cde-hp $ */
+/* 
+ * tclLink.c --
+ *
+ *	This file implements linked variables (a C variable that is
+ *	tied to a Tcl variable).  The idea of linked variables was
+ *	first suggested by Andreas Stolcke and this implementation is
+ *	based heavily on a prototype implementation provided by
+ *	him.
+ *
+ * Copyright (c) 1993 The Regents of the University of California.
+ * Copyright (c) 1994 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclLink.c 1.12 96/02/15 11:50:26
+ */
+
+#include "tclInt.h"
+
+/*
+ * For each linked variable there is a data structure of the following
+ * type, which describes the link and is the clientData for the trace
+ * set on the Tcl variable.
+ */
+
+typedef struct Link {
+    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
+    char *varName;		/* Name of variable (must be global).  This
+				 * is needed during trace callbacks, since
+				 * the actual variable may be aliased at
+				 * that time via upvar. */
+    char *addr;			/* Location of C variable. */
+    int type;			/* Type of link (TCL_LINK_INT, etc.). */
+    int writable;		/* Zero means Tcl variable is read-only. */
+    union {
+	int i;
+	double d;
+    } lastValue;		/* Last known value of C variable;  used to
+				 * avoid string conversions. */
+} Link;
+
+/*
+ * Forward references to procedures defined later in this file:
+ */
+
+static char *		LinkTraceProc _ANSI_ARGS_((ClientData clientData,
+			    Tcl_Interp *interp, char *name1, char *name2,
+			    int flags));
+static char *		StringValue _ANSI_ARGS_((Link *linkPtr,
+			    char *buffer));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LinkVar --
+ *
+ *	Link a C variable to a Tcl variable so that changes to either
+ *	one causes the other to change.
+ *
+ * Results:
+ *	The return value is TCL_OK if everything went well or TCL_ERROR
+ *	if an error occurred (interp->result is also set after errors).
+ *
+ * Side effects:
+ *	The value at *addr is linked to the Tcl variable "varName",
+ *	using "type" to convert between string values for Tcl and
+ *	binary values for *addr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LinkVar(interp, varName, addr, type)
+    Tcl_Interp *interp;		/* Interpreter in which varName exists. */
+    char *varName;		/* Name of a global variable in interp. */
+    char *addr;			/* Address of a C variable to be linked
+				 * to varName. */
+    int type;			/* Type of C variable: TCL_LINK_INT, etc. 
+				 * Also may have TCL_LINK_READ_ONLY
+				 * OR'ed in. */
+{
+    Link *linkPtr;
+    char buffer[TCL_DOUBLE_SPACE];
+    int code;
+
+    linkPtr = (Link *) ckalloc(sizeof(Link));
+    linkPtr->interp = interp;
+    linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1));
+    strcpy(linkPtr->varName, varName);
+    linkPtr->addr = addr;
+    linkPtr->type = type & ~TCL_LINK_READ_ONLY;
+    linkPtr->writable = (type & TCL_LINK_READ_ONLY) == 0;
+    if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer),
+	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
+	ckfree(linkPtr->varName);
+	ckfree((char *) linkPtr);
+	return TCL_ERROR;
+    }
+    code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
+	    |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
+	    (ClientData) linkPtr);
+    if (code != TCL_OK) {
+	ckfree(linkPtr->varName);
+	ckfree((char *) linkPtr);
+    }
+    return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UnlinkVar --
+ *
+ *	Destroy the link between a Tcl variable and a C variable.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	If "varName" was previously linked to a C variable, the link
+ *	is broken to make the variable independent.  If there was no
+ *	previous link for "varName" then nothing happens.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_UnlinkVar(interp, varName)
+    Tcl_Interp *interp;		/* Interpreter containing variable to unlink. */
+    char *varName;		/* Global variable in interp to unlink. */
+{
+    Link *linkPtr;
+
+    linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
+	    LinkTraceProc, (ClientData) NULL);
+    if (linkPtr == NULL) {
+	return;
+    }
+    Tcl_UntraceVar(interp, varName,
+	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+	    LinkTraceProc, (ClientData) linkPtr);
+    ckfree(linkPtr->varName);
+    ckfree((char *) linkPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UpdateLinkedVar --
+ *
+ *	This procedure is invoked after a linked variable has been
+ *	changed by C code.  It updates the Tcl variable so that
+ *	traces on the variable will trigger.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The Tcl variable "varName" is updated from its C value,
+ *	causing traces on the variable to trigger.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_UpdateLinkedVar(interp, varName)
+    Tcl_Interp *interp;		/* Interpreter containing variable. */
+    char *varName;		/* Name of global variable that is linked. */
+{
+    Link *linkPtr;
+    char buffer[TCL_DOUBLE_SPACE];
+
+    linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
+	    LinkTraceProc, (ClientData) NULL);
+    if (linkPtr == NULL) {
+	return;
+    }
+    Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
+	    TCL_GLOBAL_ONLY);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * LinkTraceProc --
+ *
+ *	This procedure is invoked when a linked Tcl variable is read,
+ *	written, or unset from Tcl.  It's responsible for keeping the
+ *	C variable in sync with the Tcl variable.
+ *
+ * Results:
+ *	If all goes well, NULL is returned; otherwise an error message
+ *	is returned.
+ *
+ * Side effects:
+ *	The C variable may be updated to make it consistent with the
+ *	Tcl variable, or the Tcl variable may be overwritten to reject
+ *	a modification.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+LinkTraceProc(clientData, interp, name1, name2, flags)
+    ClientData clientData;	/* Contains information about the link. */
+    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
+    char *name1;		/* First part of variable name. */
+    char *name2;		/* Second part of variable name. */
+    int flags;			/* Miscellaneous additional information. */
+{
+    Link *linkPtr = (Link *) clientData;
+    int changed;
+    char buffer[TCL_DOUBLE_SPACE];
+    char *value, **pp;
+    Tcl_DString savedResult;
+
+    /*
+     * If the variable is being unset, then just re-create it (with a
+     * trace) unless the whole interpreter is going away.
+     */
+
+    if (flags & TCL_TRACE_UNSETS) {
+	if (flags & TCL_INTERP_DESTROYED) {
+	    ckfree(linkPtr->varName);
+	    ckfree((char *) linkPtr);
+	} else if (flags & TCL_TRACE_DESTROYED) {
+	    Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
+		    TCL_GLOBAL_ONLY);
+	    Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY
+		    |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+		    LinkTraceProc, (ClientData) linkPtr);
+	}
+	return NULL;
+    }
+
+    /*
+     * For read accesses, update the Tcl variable if the C variable
+     * has changed since the last time we updated the Tcl variable.
+     */
+
+    if (flags & TCL_TRACE_READS) {
+	switch (linkPtr->type) {
+	    case TCL_LINK_INT:
+	    case TCL_LINK_BOOLEAN:
+		changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
+		break;
+	    case TCL_LINK_DOUBLE:
+		changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
+		break;
+	    case TCL_LINK_STRING:
+		changed = 1;
+		break;
+	    default:
+		return "internal error: bad linked variable type";
+	}
+	if (changed) {
+	    Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
+		    TCL_GLOBAL_ONLY);
+	}
+	return NULL;
+    }
+
+    /*
+     * For writes, first make sure that the variable is writable.  Then
+     * convert the Tcl value to C if possible.  If the variable isn't
+     * writable or can't be converted, then restore the varaible's old
+     * value and return an error.  Another tricky thing: we have to save
+     * and restore the interpreter's result, since the variable access
+     * could occur when the result has been partially set.
+     */
+
+    if (!linkPtr->writable) {
+	Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
+		TCL_GLOBAL_ONLY);
+	return "linked variable is read-only";
+    }
+    value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY);
+    if (value == NULL) {
+	/*
+	 * This shouldn't ever happen.
+	 */
+	return "internal error: linked variable couldn't be read";
+    }
+    Tcl_DStringInit(&savedResult);
+    Tcl_DStringAppend(&savedResult, interp->result, -1);
+    Tcl_ResetResult(interp);
+    switch (linkPtr->type) {
+	case TCL_LINK_INT:
+	    if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) {
+		Tcl_DStringResult(interp, &savedResult);
+		Tcl_SetVar(interp, linkPtr->varName,
+			StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
+		return "variable must have integer value";
+	    }
+	    *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
+	    break;
+	case TCL_LINK_DOUBLE:
+	    if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d)
+		    != TCL_OK) {
+		Tcl_DStringResult(interp, &savedResult);
+		Tcl_SetVar(interp, linkPtr->varName,
+			StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
+		return "variable must have real value";
+	    }
+	    *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
+	    break;
+	case TCL_LINK_BOOLEAN:
+	    if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i)
+		    != TCL_OK) {
+		Tcl_DStringResult(interp, &savedResult);
+		Tcl_SetVar(interp, linkPtr->varName,
+			StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
+		return "variable must have boolean value";
+	    }
+	    *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
+	    break;
+	case TCL_LINK_STRING:
+	    pp = (char **)(linkPtr->addr);
+	    if (*pp != NULL) {
+		ckfree(*pp);
+	    }
+	    *pp = (char *) ckalloc((unsigned) (strlen(value) + 1));
+	    strcpy(*pp, value);
+	    break;
+	default:
+	    return "internal error: bad linked variable type";
+    }
+    Tcl_DStringResult(interp, &savedResult);
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringValue --
+ *
+ *	Converts the value of a C variable to a string for use in a
+ *	Tcl variable to which it is linked.
+ *
+ * Results:
+ *	The return value is a pointer
+ to a string that represents
+ *	the value of the C variable given by linkPtr.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+StringValue(linkPtr, buffer)
+    Link *linkPtr;		/* Structure describing linked variable. */
+    char *buffer;		/* Small buffer to use for converting
+				 * values.  Must have TCL_DOUBLE_SPACE
+				 * bytes or more. */
+{
+    char *p;
+
+    switch (linkPtr->type) {
+	case TCL_LINK_INT:
+	    linkPtr->lastValue.i = *(int *)(linkPtr->addr);
+	    sprintf(buffer, "%d", linkPtr->lastValue.i);
+	    return buffer;
+	case TCL_LINK_DOUBLE:
+	    linkPtr->lastValue.d = *(double *)(linkPtr->addr);
+	    Tcl_PrintDouble(linkPtr->interp, linkPtr->lastValue.d, buffer);
+	    return buffer;
+	case TCL_LINK_BOOLEAN:
+	    linkPtr->lastValue.i = *(int *)(linkPtr->addr);
+	    if (linkPtr->lastValue.i != 0) {
+		return "1";
+	    }
+	    return "0";
+	case TCL_LINK_STRING:
+	    p = *(char **)(linkPtr->addr);
+	    if (p == NULL) {
+		return "NULL";
+	    }
+	    return p;
+    }
+
+    /*
+     * This code only gets executed if the link type is unknown
+     * (shouldn't ever happen).
+     */
+
+    return "??";
+}

cde/programs/dtdocbook/tcl/tclLoad.c

@@ -0,0 +1,601 @@
+/* $XConsortium: tclLoad.c /main/2 1996/08/08 14:45:13 cde-hp $ */
+/* 
+ * tclLoad.c --
+ *
+ *	This file provides the generic portion (those that are the same
+ *	on all platforms) of Tcl's dynamic loading facilities.
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * 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
+ */
+
+#include "tclInt.h"
+
+/*
+ * The following structure describes a package that has been loaded
+ * either dynamically (with the "load" command) or statically (as
+ * indicated by a call to Tcl_PackageLoaded).  All such packages
+ * are linked together into a single list for the process.  Packages
+ * are never unloaded, so these structures are never freed.
+ */
+
+typedef struct LoadedPackage {
+    char *fileName;		/* Name of the file from which the
+				 * package was loaded.  An empty string
+				 * means the package is loaded statically.
+				 * Malloc-ed. */
+    char *packageName;		/* Name of package prefix for the package,
+				 * properly capitalized (first letter UC,
+				 * others LC), no "_", as in "Net". 
+				 * Malloc-ed. */
+    Tcl_PackageInitProc *initProc;
+				/* Initialization procedure to call to
+				 * incorporate this package into a trusted
+				 * interpreter. */
+    Tcl_PackageInitProc *safeInitProc;
+				/* Initialization procedure to call to
+				 * incorporate this package into a safe
+				 * interpreter (one that will execute
+				 * untrusted scripts).   NULL means the
+				 * package can't be used in unsafe
+				 * interpreters. */
+    struct LoadedPackage *nextPtr;
+				/* Next in list of all packages loaded into
+				 * this application process.  NULL means
+				 * end of list. */
+} LoadedPackage;
+
+static LoadedPackage *firstPackagePtr = NULL;
+				/* First in list of all packages loaded into
+				 * this process. */
+
+/*
+ * The following structure represents a particular package that has
+ * been incorporated into a particular interpreter (by calling its
+ * initialization procedure).  There is a list of these structures for
+ * each interpreter, with an AssocData value (key "load") for the
+ * interpreter that points to the first package (if any).
+ */
+
+typedef struct InterpPackage {
+    LoadedPackage *pkgPtr;	/* Points to detailed information about
+				 * package. */
+    struct InterpPackage *nextPtr;
+				/* Next package in this interpreter, or
+				 * NULL for end of list. */
+} InterpPackage;
+
+/*
+ * Prototypes for procedures that are private to this file:
+ */
+
+static void		LoadCleanupProc _ANSI_ARGS_((ClientData clientData,
+			    Tcl_Interp *interp));
+static void		LoadExitProc _ANSI_ARGS_((ClientData clientData));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LoadCmd --
+ *
+ *	This procedure is invoked to process the "load" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LoadCmd(dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    Tcl_Interp *target;
+    LoadedPackage *pkgPtr;
+    Tcl_DString pkgName, initName, safeInitName, fileName;
+    Tcl_PackageInitProc *initProc, *safeInitProc;
+    InterpPackage *ipFirstPtr, *ipPtr;
+    int code, c, gotPkgName;
+    char *p, *fullFileName;
+
+    if ((argc < 2) || (argc > 4)) {
+	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		" fileName ?packageName? ?interp?\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    fullFileName = Tcl_TranslateFileName(interp, argv[1], &fileName);
+    if (fullFileName == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_DStringInit(&pkgName);
+    Tcl_DStringInit(&initName);
+    Tcl_DStringInit(&safeInitName);
+    if ((argc >= 3) && (argv[2][0] != 0)) {
+	gotPkgName = 1;
+    } else {
+	gotPkgName = 0;
+    }
+    if ((fullFileName[0] == 0) && !gotPkgName) {
+	interp->result = "must specify either file name or package name";
+	code = TCL_ERROR;
+	goto done;
+    }
+
+    /*
+     * Figure out which interpreter we're going to load the package into.
+     */
+
+    target = interp;
+    if (argc == 4) {
+	target = Tcl_GetSlave(interp, argv[3]);
+	if (target == NULL) {
+	    Tcl_AppendResult(interp, "couldn't find slave interpreter named \"",
+		    argv[3], "\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+    }
+
+    /*
+     * See if the desired file is already loaded.  If so, its package
+     * name must agree with ours (if we have one).
+     */
+
+    for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
+	if (strcmp(pkgPtr->fileName, fullFileName) != 0) {
+	    continue;
+	}
+	if (gotPkgName) {
+	    char *p1, *p2;
+	    for (p1 = argv[2], p2 = pkgPtr->packageName; ; p1++, p2++) {
+		if ((isupper(*p1) ? tolower(*p1) : *p1)
+			!= (isupper(*p2) ? tolower(*p2) : *p2)) {
+		    if (fullFileName[0] == 0) {
+			/*
+			 * We're looking for a statically loaded package;
+			 * the file name is basically irrelevant here, so
+			 * don't get upset that there's some other package
+			 * with the same (empty string) file name.  Just
+			 * skip this package and go on to the next.
+			 */
+
+			goto nextPackage;
+		    }
+		    Tcl_AppendResult(interp, "file \"", fullFileName,
+			    "\" is already loaded for package \"",
+			    pkgPtr->packageName, "\"", (char *) NULL);
+		    code = TCL_ERROR;
+		    goto done;
+		}
+		if (*p1 == 0) {
+		    goto gotPkg;
+		}
+	    }
+	    nextPackage:
+	    continue;
+	}
+	break;
+    }
+    gotPkg:
+
+    /*
+     * If the file is already loaded in the target interpreter then
+     * there's nothing for us to do.
+     */
+
+    ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
+	    (Tcl_InterpDeleteProc **) NULL);
+    if (pkgPtr != NULL) {
+	for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
+	    if (ipPtr->pkgPtr == pkgPtr) {
+		code = TCL_OK;
+		goto done;
+	    }
+	}
+    }
+
+    if (pkgPtr == NULL) {
+	/*
+	 * The desired file isn't currently loaded, so load it.  It's an
+	 * error if the desired package is a static one.
+	 */
+
+	if (fullFileName[0] == 0) {
+	    Tcl_AppendResult(interp, "package \"", argv[2],
+		    "\" isn't loaded statically", (char *) NULL);
+	    code = TCL_ERROR;
+	    goto done;
+	}
+
+	/*
+	 * Figure out the module name if it wasn't provided explicitly.
+	 */
+
+	if (gotPkgName) {
+	    Tcl_DStringAppend(&pkgName, argv[2], -1);
+	} else {
+	    if (!TclGuessPackageName(fullFileName, &pkgName)) {
+		int pargc;
+		char **pargv, *pkgGuess;
+
+		/*
+		 * The platform-specific code couldn't figure out the
+		 * module name.  Make a guess by taking the last element
+		 * of the file name, stripping off any leading "lib", and
+		 * then using all of the alphabetic characters that follow
+		 * that.
+		 */
+
+		Tcl_SplitPath(fullFileName, &pargc, &pargv);
+		pkgGuess = pargv[pargc-1];
+		if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
+			&& (pkgGuess[2] == 'b')) {
+		    pkgGuess += 3;
+		}
+		for (p = pkgGuess; isalpha(*p); p++) {
+		    /* Empty loop body. */
+		}
+		if (p == pkgGuess) {
+		    ckfree((char *)pargv);
+		    Tcl_AppendResult(interp,
+			    "couldn't figure out package name for ",
+			    fullFileName, (char *) NULL);
+		    code = TCL_ERROR;
+		    goto done;
+		}
+		Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));
+		ckfree((char *)pargv);
+	    }
+	}
+
+	/*
+	 * Fix the capitalization in the package name so that the first
+	 * character is in caps but the others are all lower-case.
+	 */
+    
+	p = Tcl_DStringValue(&pkgName);
+	c = UCHAR(*p);
+	if (c != 0) {
+	    if (islower(c)) {
+		*p = (char) toupper(c);
+	    }
+	    p++;
+	    while (1) {
+		c = UCHAR(*p);
+		if (c == 0) {
+		    break;
+		}
+		if (isupper(c)) {
+		    *p = (char) tolower(c);
+		}
+		p++;
+	    }
+	}
+
+	/*
+	 * Compute the names of the two initialization procedures,
+	 * based on the package name.
+	 */
+    
+	Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
+	Tcl_DStringAppend(&initName, "_Init", 5);
+	Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
+	Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
+    
+	/*
+	 * Call platform-specific code to load the package and find the
+	 * two initialization procedures.
+	 */
+    
+	code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),
+		Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc);
+	if (code != TCL_OK) {
+	    goto done;
+	}
+	if (initProc  == NULL) {
+	    Tcl_AppendResult(interp, "couldn't find procedure ",
+		    Tcl_DStringValue(&initName), (char *) NULL);
+	    code = TCL_ERROR;
+	    goto done;
+	}
+
+	/*
+	 * Create a new record to describe this package.
+	 */
+
+	if (firstPackagePtr == NULL) {
+	    Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL);
+	}
+	pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
+	pkgPtr->fileName = (char *) ckalloc((unsigned)
+		(strlen(fullFileName) + 1));
+	strcpy(pkgPtr->fileName, fullFileName);
+	pkgPtr->packageName = (char *) ckalloc((unsigned)
+		(Tcl_DStringLength(&pkgName) + 1));
+	strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
+	pkgPtr->initProc = initProc;
+	pkgPtr->safeInitProc = safeInitProc;
+	pkgPtr->nextPtr = firstPackagePtr;
+	firstPackagePtr = pkgPtr;
+    }
+
+    /*
+     * Invoke the package's initialization procedure (either the
+     * normal one or the safe one, depending on whether or not the
+     * interpreter is safe).
+     */
+
+    if (Tcl_IsSafe(target)) {
+	if (pkgPtr->safeInitProc != NULL) {
+	    code = (*pkgPtr->safeInitProc)(target);
+	} else {
+	    Tcl_AppendResult(interp,
+		    "can't use package in a safe interpreter: ",
+		    "no ", pkgPtr->packageName, "_SafeInit procedure",
+		    (char *) NULL);
+	    code = TCL_ERROR;
+	    goto done;
+	}
+    } else {
+	code = (*pkgPtr->initProc)(target);
+    }
+    if ((code == TCL_ERROR) && (target != interp)) {
+	/*
+	 * An error occurred, so transfer error information from the
+	 * destination interpreter back to our interpreter.  Must clear
+	 * interp's result before calling Tcl_AddErrorInfo, since
+	 * Tcl_AddErrorInfo will store the interp's result in errorInfo
+	 * before appending target's $errorInfo;  we've already got
+	 * everything we need in target's $errorInfo.
+	 */
+
+	Tcl_ResetResult(interp);
+	Tcl_AddErrorInfo(interp, Tcl_GetVar2(target,
+		"errorInfo", (char *) NULL, TCL_GLOBAL_ONLY));
+	Tcl_SetVar2(interp, "errorCode", (char *) NULL,
+		Tcl_GetVar2(target, "errorCode", (char *) NULL,
+		TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY);
+	Tcl_SetResult(interp, target->result, TCL_VOLATILE);
+    }
+
+    /*
+     * Record the fact that the package has been loaded in the
+     * target interpreter.
+     */
+
+    if (code == TCL_OK) {
+	ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
+	ipPtr->pkgPtr = pkgPtr;
+	ipPtr->nextPtr = ipFirstPtr;
+	Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
+		(ClientData) ipPtr);
+    }
+
+    done:
+    Tcl_DStringFree(&pkgName);
+    Tcl_DStringFree(&initName);
+    Tcl_DStringFree(&safeInitName);
+    Tcl_DStringFree(&fileName);
+    return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_StaticPackage --
+ *
+ *	This procedure is invoked to indicate that a particular
+ *	package has been linked statically with an application.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Once this procedure completes, the package becomes loadable
+ *	via the "load" command with an empty file name.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
+    Tcl_Interp *interp;			/* If not NULL, it means that the
+					 * package has already been loaded
+					 * into the given interpreter by
+					 * calling the appropriate init proc. */
+    char *pkgName;			/* Name of package (must be properly
+					 * capitalized: first letter upper
+					 * case, others lower case). */
+    Tcl_PackageInitProc *initProc;	/* Procedure to call to incorporate
+					 * this package into a trusted
+					 * interpreter. */
+    Tcl_PackageInitProc *safeInitProc;	/* Procedure to call to incorporate
+					 * this package into a safe interpreter
+					 * (one that will execute untrusted
+					 * scripts).   NULL means the package
+					 * can't be used in safe
+					 * interpreters. */
+{
+    LoadedPackage *pkgPtr;
+    InterpPackage *ipPtr, *ipFirstPtr;
+
+    if (firstPackagePtr == NULL) {
+	Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL);
+    }
+    pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
+    pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
+    pkgPtr->fileName[0] = 0;
+    pkgPtr->packageName = (char *) ckalloc((unsigned)
+	    (strlen(pkgName) + 1));
+    strcpy(pkgPtr->packageName, pkgName);
+    pkgPtr->initProc = initProc;
+    pkgPtr->safeInitProc = safeInitProc;
+    pkgPtr->nextPtr = firstPackagePtr;
+    firstPackagePtr = pkgPtr;
+
+    if (interp != NULL) {
+	ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
+		(Tcl_InterpDeleteProc **) NULL);
+	ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
+	ipPtr->pkgPtr = pkgPtr;
+	ipPtr->nextPtr = ipFirstPtr;
+	Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,
+		(ClientData) ipPtr);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetLoadedPackages --
+ *
+ *	This procedure returns information about all of the files
+ *	that are loaded (either in a particular intepreter, or
+ *	for all interpreters).
+ *
+ * Results:
+ *	The return value is a standard Tcl completion code.  If
+ *	successful, a list of lists is placed in interp->result.
+ *	Each sublist corresponds to one loaded file;  its first
+ *	element is the name of the file (or an empty string for
+ *	something that's statically loaded) and the second element
+ *	is the name of the package in that file.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGetLoadedPackages(interp, targetName)
+    Tcl_Interp *interp;		/* Interpreter in which to return
+				 * information or error message. */
+    char *targetName;		/* Name of target interpreter or NULL.
+				 * If NULL, return info about all interps;
+				 * otherwise, just return info about this
+				 * interpreter. */
+{
+    Tcl_Interp *target;
+    LoadedPackage *pkgPtr;
+    InterpPackage *ipPtr;
+    char *prefix;
+
+    if (targetName == NULL) {
+	/* 
+	 * Return information about all of the available packages.
+	 */
+
+	prefix = "{";
+	for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
+		pkgPtr = pkgPtr->nextPtr) {
+	    Tcl_AppendResult(interp, prefix, (char *) NULL);
+	    Tcl_AppendElement(interp, pkgPtr->fileName);
+	    Tcl_AppendElement(interp, pkgPtr->packageName);
+	    Tcl_AppendResult(interp, "}", (char *) NULL);
+	    prefix = " {";
+	}
+	return TCL_OK;
+    }
+
+    /*
+     * Return information about only the packages that are loaded in
+     * a given interpreter.
+     */
+
+    target = Tcl_GetSlave(interp, targetName);
+    if (target == NULL) {
+	Tcl_AppendResult(interp, "couldn't find slave interpreter named \"",
+		targetName, "\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
+	    (Tcl_InterpDeleteProc **) NULL);
+    prefix = "{";
+    for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
+	pkgPtr = ipPtr->pkgPtr;
+	Tcl_AppendResult(interp, prefix, (char *) NULL);
+	Tcl_AppendElement(interp, pkgPtr->fileName);
+	Tcl_AppendElement(interp, pkgPtr->packageName);
+	Tcl_AppendResult(interp, "}", (char *) NULL);
+	prefix = " {";
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * LoadCleanupProc --
+ *
+ *	This procedure is called to delete all of the InterpPackage
+ *	structures for an interpreter when the interpreter is deleted.
+ *	It gets invoked via the Tcl AssocData mechanism.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Storage for all of the InterpPackage procedures for interp
+ *	get deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+LoadCleanupProc(clientData, interp)
+    ClientData clientData;	/* Pointer to first InterpPackage structure
+				 * for interp. */
+    Tcl_Interp *interp;		/* Interpreter that is being deleted. */
+{
+    InterpPackage *ipPtr, *nextPtr;
+
+    ipPtr = (InterpPackage *) clientData;
+    while (ipPtr != NULL) {
+	nextPtr = ipPtr->nextPtr;
+	ckfree((char *) ipPtr);
+	ipPtr = nextPtr;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * LoadExitProc --
+ *
+ *	This procedure is invoked just before the application exits.
+ *	It frees all of the LoadedPackage structures.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Memory is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+LoadExitProc(clientData)
+    ClientData clientData;		/* Not used. */
+{
+    LoadedPackage *pkgPtr;
+
+    while (firstPackagePtr != NULL) {
+	pkgPtr = firstPackagePtr;
+	firstPackagePtr = pkgPtr->nextPtr;
+	ckfree(pkgPtr->fileName);
+	ckfree(pkgPtr->packageName);
+	ckfree((char *) pkgPtr);
+    }
+}

cde/programs/dtdocbook/tcl/tclLoadNone.c

@@ -0,0 +1,82 @@
+/* $XConsortium: tclLoadNone.c /main/2 1996/08/08 14:45:21 cde-hp $ */
+/* 
+ * tclLoadNone.c --
+ *
+ *	This procedure provides a version of the TclLoadFile for use
+ *	in systems that don't support dynamic loading; it just returns
+ *	an error.
+ *
+ * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclLoadNone.c 1.5 96/02/15 11:43:01
+ */
+
+#include "tclInt.h"
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLoadFile --
+ *
+ *	This procedure is called to carry out dynamic loading of binary
+ *	code;  it is intended for use only on systems that don't support
+ *	dynamic loading (it returns an error).
+ *
+ * Results:
+ *	The result is TCL_ERROR, and an error message is left in
+ *	interp->result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr)
+    Tcl_Interp *interp;		/* Used for error reporting. */
+    char *fileName;		/* Name of the file containing the desired
+				 * code. */
+    char *sym1, *sym2;		/* Names of two procedures to look up in
+				 * the file's symbol table. */
+    Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
+				/* Where to return the addresses corresponding
+				 * to sym1 and sym2. */
+{
+    interp->result =
+	    "dynamic loading is not currently available on this system";
+    return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGuessPackageName --
+ *
+ *	If the "load" command is invoked without providing a package
+ *	name, this procedure is invoked to try to figure it out.
+ *
+ * Results:
+ *	Always returns 0 to indicate that we couldn't figure out a
+ *	package name;  generic code will then try to guess the package
+ *	from the file name.  A return value of 1 would have meant that
+ *	we figured out the package name and put it in bufPtr.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGuessPackageName(fileName, bufPtr)
+    char *fileName;		/* Name of file containing package (already
+				 * translated to local form if needed). */
+    Tcl_DString *bufPtr;	/* Initialized empty dstring.  Append
+				 * package name to this if possible. */
+{
+    return 0;
+}

cde/programs/dtdocbook/tcl/tclMain.c

@@ -0,0 +1,348 @@
+/* $XConsortium: tclMain.c /main/2 1996/08/08 14:45:29 cde-hp $ */
+/* 
+ * tclMain.c --
+ *
+ *	Main program for Tcl shells and other Tcl-based applications.
+ *
+ * Copyright (c) 1988-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclMain.c 1.50 96/04/10 16:40:57
+ */
+
+#include "tcl.h"
+#include "tclInt.h"
+
+/*
+ * The following code ensures that tclLink.c is linked whenever
+ * Tcl is linked.  Without this code there's no reference to the
+ * code in that file from anywhere in Tcl, so it may not be
+ * linked into the application.
+ */
+
+EXTERN int Tcl_LinkVar();
+int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;
+
+/*
+ * Declarations for various library procedures and variables (don't want
+ * to include tclPort.h here, because people might copy this file out of
+ * the Tcl source directory to make their own modified versions).
+ * Note:  "exit" should really be declared here, but there's no way to
+ * declare it without causing conflicts with other definitions elsewher
+ * on some systems, so it's better just to leave it out.
+ */
+
+extern int		isatty _ANSI_ARGS_((int fd));
+extern char *		strcpy _ANSI_ARGS_((char *dst, CONST char *src));
+
+static Tcl_Interp *interp;	/* Interpreter for application. */
+static Tcl_DString command;	/* Used to buffer incomplete commands being
+				 * read from stdin. */
+#ifdef TCL_MEM_DEBUG
+static char dumpFile[100];	/* Records where to dump memory allocation
+				 * information. */
+static int quitFlag = 0;	/* 1 means the "checkmem" command was
+				 * invoked, so the application should quit
+				 * and dump memory allocation information. */
+#endif
+
+/*
+ * Forward references for procedures defined later in this file:
+ */
+
+#ifdef TCL_MEM_DEBUG
+static int		CheckmemCmd _ANSI_ARGS_((ClientData clientData,
+			    Tcl_Interp *interp, int argc, char *argv[]));
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Main --
+ *
+ *	Main program for tclsh and most other Tcl-based applications.
+ *
+ * Results:
+ *	None. This procedure never returns (it exits the process when
+ *	it's done.
+ *
+ * Side effects:
+ *	This procedure initializes the Tk world and then starts
+ *	interpreting commands;  almost anything could happen, depending
+ *	on the script being interpreted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_Main(argc, argv, appInitProc)
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Array of argument strings. */
+    Tcl_AppInitProc *appInitProc;	/* Application-specific initialization
+					 * procedure to call after most
+					 * initialization but before starting
+					 * to execute commands. */
+{
+    char buffer[1000], *cmd, *args, *fileName;
+    int code, gotPartial, tty, length;
+    int exitCode = 0;
+    Tcl_Channel inChannel, outChannel, errChannel;
+    Tcl_DString temp;
+
+    Tcl_FindExecutable(argv[0]);
+    interp = Tcl_CreateInterp();
+#ifdef TCL_MEM_DEBUG
+    Tcl_InitMemory(interp);
+    Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
+	    (Tcl_CmdDeleteProc *) NULL);
+#endif
+
+    /*
+     * Make command-line arguments available in the Tcl variables "argc"
+     * and "argv".  If the first argument doesn't start with a "-" then
+     * strip it off and use it as the name of a script file to process.
+     */
+
+    fileName = NULL;
+    if ((argc > 1) && (argv[1][0] != '-')) {
+	fileName = argv[1];
+	argc--;
+	argv++;
+    }
+    args = Tcl_Merge(argc-1, argv+1);
+    Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
+    ckfree(args);
+    sprintf(buffer, "%d", argc-1);
+    Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
+    Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
+	    TCL_GLOBAL_ONLY);
+
+    /*
+     * Set the "tcl_interactive" variable.
+     */
+
+    tty = isatty(0);
+    Tcl_SetVar(interp, "tcl_interactive",
+	    ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
+    
+    /*
+     * Invoke application-specific initialization.
+     */
+
+    if ((*appInitProc)(interp) != TCL_OK) {
+	errChannel = Tcl_GetStdChannel(TCL_STDERR);
+	if (errChannel) {
+	    Tcl_Write(errChannel,
+		    "application-specific initialization failed: ", -1);
+	    Tcl_Write(errChannel, interp->result, -1);
+	    Tcl_Write(errChannel, "\n", 1);
+	}
+    }
+
+    /*
+     * If a script file was specified then just source that file
+     * and quit.
+     */
+
+    if (fileName != NULL) {
+	code = Tcl_EvalFile(interp, fileName);
+	if (code != TCL_OK) {
+	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
+	    if (errChannel) {
+		/*
+		 * The following statement guarantees that the errorInfo
+		 * variable is set properly.
+		 */
+
+		Tcl_AddErrorInfo(interp, "");
+		Tcl_Write(errChannel,
+			Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1);
+		Tcl_Write(errChannel, "\n", 1);
+	    }
+	    exitCode = 1;
+	}
+	goto done;
+    }
+
+    /*
+     * We're running interactively.  Source a user-specific startup
+     * file if the application specified one and if the file exists.
+     */
+
+    fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
+
+    if (fileName != NULL) {
+        Tcl_Channel c;
+	char *fullName;
+
+        Tcl_DStringInit(&temp);
+	fullName = Tcl_TranslateFileName(interp, fileName, &temp);
+	if (fullName == NULL) {
+	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
+	    if (errChannel) {
+		Tcl_Write(errChannel, interp->result, -1);
+		Tcl_Write(errChannel, "\n", 1);
+	    }
+	} else {
+
+	    /*
+	     * Test for the existence of the rc file before trying to read it.
+	     */
+
+            c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
+            if (c != (Tcl_Channel) NULL) {
+                Tcl_Close(NULL, c);
+		if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
+		    errChannel = Tcl_GetStdChannel(TCL_STDERR);
+		    if (errChannel) {
+			Tcl_Write(errChannel, interp->result, -1);
+			Tcl_Write(errChannel, "\n", 1);
+		    }
+		}
+	    }
+	}
+        Tcl_DStringFree(&temp);
+    }
+
+    /*
+     * Process commands from stdin until there's an end-of-file.  Note
+     * that we need to fetch the standard channels again after every
+     * eval, since they may have been changed.
+     */
+
+    gotPartial = 0;
+    Tcl_DStringInit(&command);
+    inChannel = Tcl_GetStdChannel(TCL_STDIN);
+    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+    while (1) {
+	if (tty) {
+	    char *promptCmd;
+
+	    promptCmd = Tcl_GetVar(interp,
+		gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
+	    if (promptCmd == NULL) {
+defaultPrompt:
+		if (!gotPartial && outChannel) {
+		    Tcl_Write(outChannel, "% ", 2);
+		}
+	    } else {
+		code = Tcl_Eval(interp, promptCmd);
+		inChannel = Tcl_GetStdChannel(TCL_STDIN);
+		outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+		errChannel = Tcl_GetStdChannel(TCL_STDERR);
+		if (code != TCL_OK) {
+		    if (errChannel) {
+			Tcl_Write(errChannel, interp->result, -1);
+			Tcl_Write(errChannel, "\n", 1);
+		    }
+		    Tcl_AddErrorInfo(interp,
+			    "\n    (script that generates prompt)");
+		    goto defaultPrompt;
+		}
+	    }
+	    if (outChannel) {
+		Tcl_Flush(outChannel);
+	    }
+	}
+	if (!inChannel) {
+	    goto done;
+	}
+        length = Tcl_Gets(inChannel, &command);
+	if (length < 0) {
+	    goto done;
+	}
+	if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
+	    goto done;
+	}
+
+        /*
+         * Add the newline removed by Tcl_Gets back to the string.
+         */
+        
+        (void) Tcl_DStringAppend(&command, "\n", -1);
+
+	cmd = Tcl_DStringValue(&command);
+	if (!Tcl_CommandComplete(cmd)) {
+	    gotPartial = 1;
+	    continue;
+	}
+
+	gotPartial = 0;
+	code = Tcl_RecordAndEval(interp, cmd, 0);
+	inChannel = Tcl_GetStdChannel(TCL_STDIN);
+	outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+	errChannel = Tcl_GetStdChannel(TCL_STDERR);
+	Tcl_DStringFree(&command);
+	if (code != TCL_OK) {
+	    if (errChannel) {
+		Tcl_Write(errChannel, interp->result, -1);
+		Tcl_Write(errChannel, "\n", 1);
+	    }
+	} else if (tty && (*interp->result != 0)) {
+	    if (outChannel) {
+		Tcl_Write(outChannel, interp->result, -1);
+		Tcl_Write(outChannel, "\n", 1);
+	    }
+	}
+#ifdef TCL_MEM_DEBUG
+	if (quitFlag) {
+	    Tcl_DeleteInterp(interp);
+	    Tcl_Exit(0);
+	}
+#endif
+    }
+
+    /*
+     * Rather than calling exit, invoke the "exit" command so that
+     * users can replace "exit" with some other command to do additional
+     * cleanup on exit.  The Tcl_Eval call should never return.
+     */
+
+done:
+    sprintf(buffer, "exit %d", exitCode);
+    Tcl_Eval(interp, buffer);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CheckmemCmd --
+ *
+ *	This is the command procedure for the "checkmem" command, which
+ *	causes the application to exit after printing information about
+ *	memory usage to the file passed to this command as its first
+ *	argument.
+ *
+ * Results:
+ *	Returns a standard Tcl completion code.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+#ifdef TCL_MEM_DEBUG
+
+	/* ARGSUSED */
+static int
+CheckmemCmd(clientData, interp, argc, argv)
+    ClientData clientData;		/* Not used. */
+    Tcl_Interp *interp;			/* Interpreter for evaluation. */
+    int argc;				/* Number of arguments. */
+    char *argv[];			/* String values of arguments. */
+{
+    extern char *tclMemDumpFileName;
+    if (argc != 2) {
+	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		" fileName\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    strcpy(dumpFile, argv[1]);
+    tclMemDumpFileName = dumpFile;
+    quitFlag = 1;
+    return TCL_OK;
+}
+#endif

cde/programs/dtdocbook/tcl/tclMtherr.c

@@ -0,0 +1,87 @@
+/* $XConsortium: tclMtherr.c /main/2 1996/08/08 14:45:38 cde-hp $ */
+/* 
+ * tclMatherr.c --
+ *
+ *	This function provides a default implementation of the
+ *	"matherr" function, for SYS-V systems where it's needed.
+ *
+ * Copyright (c) 1993-1994 The Regents of the University of California.
+ * Copyright (c) 1994 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclMtherr.c 1.11 96/02/15 11:58:36
+ */
+
+#include "tclInt.h"
+#include <math.h>
+
+#ifndef TCL_GENERIC_ONLY
+#include "tclPort.h"
+#else
+#define NO_ERRNO_H
+#endif
+
+#ifdef NO_ERRNO_H
+extern int errno;			/* Use errno from tclExpr.c. */
+#define EDOM 33
+#define ERANGE 34
+#endif
+
+/*
+ * The following variable is secretly shared with Tcl so we can
+ * tell if expression evaluation is in progress.  If not, matherr
+ * just emulates the default behavior, which includes printing
+ * a message.
+ */
+
+extern int tcl_MathInProgress;
+
+/*
+ * The following definitions allow matherr to compile on systems
+ * that don't really support it.  The compiled procedure is bogus,
+ * but it will never be executed on these systems anyway.
+ */
+
+#ifndef NEED_MATHERR
+struct exception {
+    int type;
+};
+#define DOMAIN 0
+#define SING 0
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * matherr --
+ *
+ *	This procedure is invoked on Sys-V systems when certain
+ *	errors occur in mathematical functions.  Type "man matherr"
+ *	for more information on how this function works.
+ *
+ * Results:
+ *	Returns 1 to indicate that we've handled the error
+ *	locally.
+ *
+ * Side effects:
+ *	Sets errno based on what's in xPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+matherr(xPtr)
+    struct exception *xPtr;	/* Describes error that occurred. */
+{
+    if (!tcl_MathInProgress) {
+	return 0;
+    }
+    if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) {
+	errno = EDOM;
+    } else {
+	errno = ERANGE;
+    }
+    return 1;
+}

cde/programs/dtdocbook/tcl/tclNotify.c

@@ -0,0 +1,579 @@
+/* $XConsortium: tclNotify.c /main/2 1996/08/08 14:45:43 cde-hp $ */
+/* 
+ * tclNotify.c --
+ *
+ *	This file provides the parts of the Tcl event notifier that are
+ *	the same on all platforms, plus a few other parts that are used
+ *	on more than one platform but not all.
+ *
+ *	The notifier is the lowest-level part of the event system.  It
+ *	manages an event queue that holds Tcl_Event structures and a list
+ *	of event sources that can add events to the queue.  It also
+ *	contains the procedure Tcl_DoOneEvent that invokes the event
+ *	sources and blocks to wait for new events, but Tcl_DoOneEvent
+ *	is in the platform-specific part of the notifier (in files like
+ *	tclUnixNotify.c).
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclNotify.c 1.6 96/02/29 09:20:10
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * The following variable records the address of the first event
+ * source in the list of all event sources for the application.
+ * This variable is accessed by the notifier to traverse the list
+ * and invoke each event source.
+ */
+
+TclEventSource *tclFirstEventSourcePtr = NULL;
+
+/*
+ * The following variables indicate how long to block in the event
+ * notifier the next time it blocks (default:  block forever).
+ */
+
+static int blockTimeSet = 0;	/* 0 means there is no maximum block
+				 * time:  block forever. */
+static Tcl_Time blockTime;	/* If blockTimeSet is 1, gives the
+				 * maximum elapsed time for the next block. */
+
+/*
+ * The following variables keep track of the event queue.  In addition
+ * to the first (next to be serviced) and last events in the queue,
+ * we keep track of a "marker" event.  This provides a simple priority
+ * mechanism whereby events can be inserted at the front of the queue
+ * but behind all other high-priority events already in the queue (this
+ * is used for things like a sequence of Enter and Leave events generated
+ * during a grab in Tk).
+ */
+
+static Tcl_Event *firstEventPtr = NULL;
+				/* First pending event, or NULL if none. */
+static Tcl_Event *lastEventPtr = NULL;
+				/* Last pending event, or NULL if none. */
+static Tcl_Event *markerEventPtr = NULL;
+				/* Last high-priority event in queue, or
+				 * NULL if none. */
+
+/*
+ * Prototypes for procedures used only in this file:
+ */
+
+static int		ServiceEvent _ANSI_ARGS_((int flags));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateEventSource --
+ *
+ *	This procedure is invoked to create a new source of events.
+ *	The source is identified by a procedure that gets invoked
+ *	during Tcl_DoOneEvent to check for events on that source
+ *	and queue them.
+ *
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent
+ *	runs out of things to do.  SetupProc will be invoked before
+ *	Tcl_DoOneEvent calls select or whatever else it uses to wait
+ *	for events.  SetupProc typically calls functions like Tcl_WatchFile
+ *	or Tcl_SetMaxBlockTime to indicate what to wait for.
+ *
+ *	CheckProc is called after select or whatever operation was actually
+ *	used to wait.  It figures out whether anything interesting actually
+ *	happened (e.g. by calling Tcl_FileReady), and then calls
+ *	Tcl_QueueEvent to queue any events that are ready.
+ *
+ *	Each of these procedures is passed two arguments, e.g.
+ *		(*checkProc)(ClientData clientData, int flags));
+ *	ClientData is the same as the clientData argument here, and flags
+ *	is a combination of things like TCL_FILE_EVENTS that indicates
+ *	what events are of interest:  setupProc and checkProc use flags
+ *	to figure out whether their events are relevant or not.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_CreateEventSource(setupProc, checkProc, clientData)
+    Tcl_EventSetupProc *setupProc;	/* Procedure to invoke to figure out
+					 * what to wait for. */
+    Tcl_EventCheckProc *checkProc;	/* Procedure to call after waiting
+					 * to see what happened. */
+    ClientData clientData;		/* One-word argument to pass to
+					 * setupProc and checkProc. */
+{
+    TclEventSource *sourcePtr;
+
+    sourcePtr = (TclEventSource *) ckalloc(sizeof(TclEventSource));
+    sourcePtr->setupProc = setupProc;
+    sourcePtr->checkProc = checkProc;
+    sourcePtr->clientData = clientData;
+    sourcePtr->nextPtr = tclFirstEventSourcePtr;
+    tclFirstEventSourcePtr = sourcePtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteEventSource --
+ *
+ *	This procedure is invoked to delete the source of events
+ *	given by proc and clientData.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The given event source is cancelled, so its procedure will
+ *	never again be called.  If no such source exists, nothing
+ *	happens.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteEventSource(setupProc, checkProc, clientData)
+    Tcl_EventSetupProc *setupProc;	/* Procedure to invoke to figure out
+					 * what to wait for. */
+    Tcl_EventCheckProc *checkProc;	/* Procedure to call after waiting
+					 * to see what happened. */
+    ClientData clientData;		/* One-word argument to pass to
+					 * setupProc and checkProc. */
+{
+    TclEventSource *sourcePtr, *prevPtr;
+
+    for (sourcePtr = tclFirstEventSourcePtr, prevPtr = NULL;
+	    sourcePtr != NULL;
+	    prevPtr = sourcePtr, sourcePtr = sourcePtr->nextPtr) {
+	if ((sourcePtr->setupProc != setupProc)
+		|| (sourcePtr->checkProc != checkProc)
+		|| (sourcePtr->clientData != clientData)) {
+	    continue;
+	}
+	if (prevPtr == NULL) {
+	    tclFirstEventSourcePtr = sourcePtr->nextPtr;
+	} else {
+	    prevPtr->nextPtr = sourcePtr->nextPtr;
+	}
+	ckfree((char *) sourcePtr);
+	return;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_QueueEvent --
+ *
+ *	Insert an event into the Tk event queue at one of three
+ *	positions: the head, the tail, or before a floating marker.
+ *	Events inserted before the marker will be processed in
+ *	first-in-first-out order, but before any events inserted at
+ *	the tail of the queue.  Events inserted at the head of the
+ *	queue will be processed in last-in-first-out order.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_QueueEvent(evPtr, position)
+    Tcl_Event* evPtr;		/* Event to add to queue.  The storage
+				 * space must have been allocated the caller
+				 * with malloc (ckalloc), and it becomes
+				 * the property of the event queue.  It
+				 * will be freed after the event has been
+				 * handled. */
+    Tcl_QueuePosition position;	/* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
+				 * TCL_QUEUE_MARK. */
+{
+    if (position == TCL_QUEUE_TAIL) {
+	/*
+	 * Append the event on the end of the queue.
+	 */
+
+	evPtr->nextPtr = NULL;
+	if (firstEventPtr == NULL) {
+	    firstEventPtr = evPtr;
+	} else {
+	    lastEventPtr->nextPtr = evPtr;
+	}
+	lastEventPtr = evPtr;
+    } else if (position == TCL_QUEUE_HEAD) {
+	/*
+	 * Push the event on the head of the queue.
+	 */
+
+	evPtr->nextPtr = firstEventPtr;
+	if (firstEventPtr == NULL) {
+	    lastEventPtr = evPtr;
+	}	    
+	firstEventPtr = evPtr;
+    } else if (position == TCL_QUEUE_MARK) {
+	/*
+	 * Insert the event after the current marker event and advance
+	 * the marker to the new event.
+	 */
+
+	if (markerEventPtr == NULL) {
+	    evPtr->nextPtr = firstEventPtr;
+	    firstEventPtr = evPtr;
+	} else {
+	    evPtr->nextPtr = markerEventPtr->nextPtr;
+	    markerEventPtr->nextPtr = evPtr;
+	}
+	markerEventPtr = evPtr;
+	if (evPtr->nextPtr == NULL) {
+	    lastEventPtr = evPtr;
+	}
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteEvents --
+ *
+ *	Calls a procedure for each event in the queue and deletes those
+ *	for which the procedure returns 1. Events for which the
+ *	procedure returns 0 are left in the queue.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Potentially removes one or more events from the event queue.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteEvents(proc, clientData)
+    Tcl_EventDeleteProc *proc;		/* The procedure to call. */
+    ClientData clientData;    		/* type-specific data. */
+{
+    Tcl_Event *evPtr, *prevPtr, *hold;
+
+    for (prevPtr = (Tcl_Event *) NULL, evPtr = firstEventPtr;
+             evPtr != (Tcl_Event *) NULL;
+             ) {
+        if ((*proc) (evPtr, clientData) == 1) {
+            if (firstEventPtr == evPtr) {
+                firstEventPtr = evPtr->nextPtr;
+                if (evPtr->nextPtr == (Tcl_Event *) NULL) {
+                    lastEventPtr = (Tcl_Event *) NULL;
+                }
+            } else {
+                prevPtr->nextPtr = evPtr->nextPtr;
+            }
+            hold = evPtr;
+            evPtr = evPtr->nextPtr;
+            ckfree((char *) hold);
+        } else {
+            prevPtr = evPtr;
+            evPtr = evPtr->nextPtr;
+        }
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ServiceEvent --
+ *
+ *	Process one event from the event queue.  This routine is called
+ *	by the notifier whenever it wants Tk to process an event.  
+ *
+ * Results:
+ *	The return value is 1 if the procedure actually found an event
+ *	to process.  If no processing occurred, then 0 is returned.
+ *
+ * Side effects:
+ *	Invokes all of the event handlers for the highest priority
+ *	event in the event queue.  May collapse some events into a
+ *	single event or discard stale events.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ServiceEvent(flags)
+    int flags;			/* Indicates what events should be processed.
+				 * May be any combination of TCL_WINDOW_EVENTS
+				 * TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other
+				 * flags defined elsewhere.  Events not
+				 * matching this will be skipped for processing
+				 * later. */
+{
+    Tcl_Event *evPtr, *prevPtr;
+    Tcl_EventProc *proc;
+
+    /*
+     * No event flags is equivalent to TCL_ALL_EVENTS.
+     */
+    
+    if ((flags & TCL_ALL_EVENTS) == 0) {
+	flags |= TCL_ALL_EVENTS;
+    }
+
+    /*
+     * Loop through all the events in the queue until we find one
+     * that can actually be handled.
+     */
+
+    for (evPtr = firstEventPtr; evPtr != NULL; evPtr = evPtr->nextPtr) {
+	/*
+	 * Call the handler for the event.  If it actually handles the
+	 * event then free the storage for the event.  There are two
+	 * tricky things here, but stemming from the fact that the event
+	 * code may be re-entered while servicing the event:
+	 *
+	 * 1. Set the "proc" field to NULL.  This is a signal to ourselves
+	 *    that we shouldn't reexecute the handler if the event loop
+	 *    is re-entered.
+	 * 2. When freeing the event, must search the queue again from the
+	 *    front to find it.  This is because the event queue could
+	 *    change almost arbitrarily while handling the event, so we
+	 *    can't depend on pointers found now still being valid when
+	 *    the handler returns.
+	 */
+
+	proc = evPtr->proc;
+	evPtr->proc = NULL;
+	if ((proc != NULL) && (*proc)(evPtr, flags)) {
+	    if (firstEventPtr == evPtr) {
+		firstEventPtr = evPtr->nextPtr;
+		if (evPtr->nextPtr == NULL) {
+		    lastEventPtr = NULL;
+		}
+	    } else {
+		for (prevPtr = firstEventPtr; prevPtr->nextPtr != evPtr;
+			prevPtr = prevPtr->nextPtr) {
+		    /* Empty loop body. */
+		}
+		prevPtr->nextPtr = evPtr->nextPtr;
+		if (evPtr->nextPtr == NULL) {
+		    lastEventPtr = prevPtr;
+		}
+	    }
+	    if (markerEventPtr == evPtr) {
+		markerEventPtr = NULL;
+	    }
+	    ckfree((char *) evPtr);
+	    return 1;
+	} else {
+	    /*
+	     * The event wasn't actually handled, so we have to restore
+	     * the proc field to allow the event to be attempted again.
+	     */
+
+	    evPtr->proc = proc;
+	}
+
+	/*
+	 * The handler for this event asked to defer it.  Just go on to
+	 * the next event.
+	 */
+
+	continue;
+    }
+    return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetMaxBlockTime --
+ *
+ *	This procedure is invoked by event sources to tell the notifier
+ *	how long it may block the next time it blocks.  The timePtr
+ *	argument gives a maximum time;  the actual time may be less if
+ *	some other event source requested a smaller time.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	May reduce the length of the next sleep in the notifier.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetMaxBlockTime(timePtr)
+    Tcl_Time *timePtr;		/* Specifies a maximum elapsed time for
+				 * the next blocking operation in the
+				 * event notifier. */
+{
+    if (!blockTimeSet || (timePtr->sec < blockTime.sec)
+	    || ((timePtr->sec == blockTime.sec)
+	    && (timePtr->usec < blockTime.usec))) {
+	blockTime = *timePtr;
+	blockTimeSet = 1;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DoOneEvent --
+ *
+ *	Process a single event of some sort.  If there's no work to
+ *	do, wait for an event to occur, then process it.
+ *
+ * Results:
+ *	The return value is 1 if the procedure actually found an event
+ *	to process.  If no processing occurred, then 0 is returned (this
+ *	can happen if the TCL_DONT_WAIT flag is set or if there are no
+ *	event handlers to wait for in the set specified by flags).
+ *
+ * Side effects:
+ *	May delay execution of process while waiting for an event,
+ *	unless TCL_DONT_WAIT is set in the flags argument.  Event
+ *	sources are invoked to check for and queue events.  Event
+ *	handlers may produce arbitrary side effects.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DoOneEvent(flags)
+    int flags;			/* Miscellaneous flag values:  may be any
+				 * combination of TCL_DONT_WAIT,
+				 * TCL_WINDOW_EVENTS, TCL_FILE_EVENTS,
+				 * TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, or
+				 * others defined by event sources. */
+{
+    TclEventSource *sourcePtr;
+    Tcl_Time *timePtr;
+
+    /*
+     * No event flags is equivalent to TCL_ALL_EVENTS.
+     */
+    
+    if ((flags & TCL_ALL_EVENTS) == 0) {
+	flags |= TCL_ALL_EVENTS;
+    }
+
+    /*
+     * The core of this procedure is an infinite loop, even though
+     * we only service one event.  The reason for this is that we
+     * might think we have an event ready (e.g. the connection to
+     * the server becomes readable), but then we might discover that
+     * there's nothing interesting on that connection, so no event
+     * was serviced.  Or, the select operation could return prematurely
+     * due to a signal.  The easiest thing in both these cases is
+     * just to loop back and try again.
+     */
+
+    while (1) {
+
+	/*
+	 * The first thing we do is to service any asynchronous event
+	 * handlers.
+	 */
+    
+	if (Tcl_AsyncReady()) {
+	    (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
+	    return 1;
+	}
+
+	/*
+	 * If idle events are the only things to service, skip the
+	 * main part of the loop and go directly to handle idle
+	 * events (i.e. don't wait even if TCL_DONT_WAIT isn't set.
+	 */
+
+	if (flags == TCL_IDLE_EVENTS) {
+	    flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+	    goto idleEvents;
+	}
+
+	/*
+	 * Ask Tk to service a queued event, if there are any.
+	 */
+
+	if (ServiceEvent(flags)) {
+	    return 1;
+	}
+
+	/*
+	 * There are no events already queued.  Invoke all of the
+	 * event sources to give them a chance to setup for the wait.
+	 */
+
+	blockTimeSet = 0;
+	for (sourcePtr = tclFirstEventSourcePtr; sourcePtr != NULL;
+		sourcePtr = sourcePtr->nextPtr) {
+	    (*sourcePtr->setupProc)(sourcePtr->clientData, flags);
+	}
+	if ((flags & TCL_DONT_WAIT) ||
+		((flags & TCL_IDLE_EVENTS) && TclIdlePending())) {
+	    /*
+	     * Don't block:  there are idle events waiting, or we don't
+	     * care about idle events anyway, or the caller asked us not
+	     * to block.
+	     */
+
+	    blockTime.sec = 0;
+	    blockTime.usec = 0;
+	    timePtr = &blockTime;
+	} else if (blockTimeSet) {
+	    timePtr = &blockTime;
+	} else {
+	    timePtr = NULL;
+	}
+
+	/*
+	 * Wait until an event occurs or the timer expires.
+	 */
+
+	if (Tcl_WaitForEvent(timePtr) == TCL_ERROR) {
+	    return 0;
+	}
+
+	/*
+	 * Give each of the event sources a chance to queue events,
+	 * then call ServiceEvent and give it another chance to
+	 * service events.
+	 */
+
+	for (sourcePtr = tclFirstEventSourcePtr; sourcePtr != NULL;
+		sourcePtr = sourcePtr->nextPtr) {
+	    (*sourcePtr->checkProc)(sourcePtr->clientData, flags);
+	}
+	if (ServiceEvent(flags)) {
+	    return 1;
+	}
+
+	/*
+	 * We've tried everything at this point, but nobody had anything
+	 * to do.  Check for idle events.  If none, either quit or go back
+	 * to the top and try again.
+	 */
+
+	idleEvents:
+	if ((flags & TCL_IDLE_EVENTS) && TclServiceIdle()) {
+	    return 1;
+	}
+	if (flags & TCL_DONT_WAIT) {
+	    return 0;
+	}
+    }
+}

cde/programs/dtdocbook/tcl/tclPkg.c

@@ -0,0 +1,733 @@
+/* $XConsortium: tclPkg.c /main/2 1996/08/08 14:45:54 cde-hp $ */
+/* 
+ * tclPkg.c --
+ *
+ *	This file implements package and version control for Tcl via
+ *	the "package" command and a few C APIs.
+ *
+ * Copyright (c) 1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclPkg.c 1.6 96/02/15 11:43:16
+ */
+
+#include "tclInt.h"
+
+/*
+ * Each invocation of the "package ifneeded" command creates a structure
+ * of the following type, which is used to load the package into the
+ * interpreter if it is requested with a "package require" command.
+ */
+
+typedef struct PkgAvail {
+    char *version;		/* Version string; malloc'ed. */
+    char *script;		/* Script to invoke to provide this version
+				 * of the package.  Malloc'ed and protected
+				 * by Tcl_Preserve and Tcl_Release. */
+    struct PkgAvail *nextPtr;	/* Next in list of available versions of
+				 * the same package. */
+} PkgAvail;
+
+/*
+ * For each package that is known in any way to an interpreter, there
+ * is one record of the following type.  These records are stored in
+ * the "packageTable" hash table in the interpreter, keyed by
+ * package name such as "Tk" (no version number).
+ */
+
+typedef struct Package {
+    char *version;		/* Version that has been supplied in this
+				 * interpreter via "package provide"
+				 * (malloc'ed).  NULL means the package doesn't
+				 * exist in this interpreter yet. */
+    PkgAvail *availPtr;		/* First in list of all available versions
+				 * of this package. */
+} Package;
+
+/*
+ * Prototypes for procedures defined in this file:
+ */
+
+static int		CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
+			    char *string));
+static int		ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2,
+			    int *satPtr));
+static Package *	FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
+			    char *name));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_PkgProvide --
+ *
+ *	This procedure is invoked to declare that a particular version
+ *	of a particular package is now present in an interpreter.  There
+ *	must not be any other version of this package already
+ *	provided in the interpreter.
+ *
+ * Results:
+ *	Normally returns TCL_OK;  if there is already another version
+ *	of the package loaded then TCL_ERROR is returned and an error
+ *	message is left in interp->result.
+ *
+ * Side effects:
+ *	The interpreter remembers that this package is available,
+ *	so that no other version of the package may be provided for
+ *	the interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_PkgProvide(interp, name, version)
+    Tcl_Interp *interp;		/* Interpreter in which package is now
+				 * available. */
+    char *name;			/* Name of package. */
+    char *version;		/* Version string for package. */
+{
+    Package *pkgPtr;
+
+    pkgPtr = FindPackage(interp, name);
+    if (pkgPtr->version == NULL) {
+	pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1));
+	strcpy(pkgPtr->version, version);
+	return TCL_OK;
+    }
+    if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {
+	return TCL_OK;
+    }
+    Tcl_AppendResult(interp, "conflicting versions provided for package \"",
+	    name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_PkgRequire --
+ *
+ *	This procedure is called by code that depends on a particular
+ *	version of a particular package.  If the package is not already
+ *	provided in the interpreter, this procedure invokes a Tcl script
+ *	to provide it.  If the package is already provided, this
+ *	procedure makes sure that the caller's needs don't conflict with
+ *	the version that is present.
+ *
+ * Results:
+ *	If successful, returns the version string for the currently
+ *	provided version of the package, which may be different from
+ *	the "version" argument.  If the caller's requirements
+ *	cannot be met (e.g. the version requested conflicts with
+ *	a currently provided version, or the required version cannot
+ *	be found, or the script to provide the required version
+ *	generates an error), NULL is returned and an error
+ *	message is left in interp->result.
+ *
+ * Side effects:
+ *	The script from some previous "package ifneeded" command may
+ *	be invoked to provide the package.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_PkgRequire(interp, name, version, exact)
+    Tcl_Interp *interp;		/* Interpreter in which package is now
+				 * available. */
+    char *name;			/* Name of desired package. */
+    char *version;		/* Version string for desired version;
+				 * NULL means use the latest version
+				 * available. */
+    int exact;			/* Non-zero means that only the particular
+				 * version given is acceptable. Zero means
+				 * use the latest compatible version. */
+{
+    Package *pkgPtr;
+    PkgAvail *availPtr, *bestPtr;
+    char *script;
+    int code, satisfies, result, pass;
+    Tcl_DString command;
+
+    /*
+     * It can take up to three passes to find the package:  one pass to
+     * run the "package unknown" script, one to run the "package ifneeded"
+     * script for a specific version, and a final pass to lookup the
+     * package loaded by the "package ifneeded" script.
+     */
+
+    for (pass = 1; ; pass++) {
+	pkgPtr = FindPackage(interp, name);
+	if (pkgPtr->version != NULL) {
+	    break;
+	}
+
+	/*
+	 * The package isn't yet present.  Search the list of available
+	 * versions and invoke the script for the best available version.
+	 */
+    
+	bestPtr = NULL;
+	for (availPtr = pkgPtr->availPtr; availPtr != NULL;
+		availPtr = availPtr->nextPtr) {
+	    if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
+		    bestPtr->version, (int *) NULL) <= 0)) {
+		continue;
+	    }
+	    if (version != NULL) {
+		result = ComparePkgVersions(availPtr->version, version,
+			&satisfies);
+		if ((result != 0) && exact) {
+		    continue;
+		}
+		if (!satisfies) {
+		    continue;
+		}
+	    }
+	    bestPtr = availPtr;
+	}
+	if (bestPtr != NULL) {
+	    /*
+	     * We found an ifneeded script for the package.  Be careful while
+	     * executing it:  this could cause reentrancy, so (a) protect the
+	     * script itself from deletion and (b) don't assume that bestPtr
+	     * will still exist when the script completes.
+	     */
+	
+	    script = bestPtr->script;
+	    Tcl_Preserve((ClientData) script);
+	    code = Tcl_GlobalEval(interp, script);
+	    Tcl_Release((ClientData) script);
+	    if (code != TCL_OK) {
+		if (code == TCL_ERROR) {
+		    Tcl_AddErrorInfo(interp,
+			    "\n    (\"package ifneeded\" script)");
+		}
+		return NULL;
+	    }
+	    Tcl_ResetResult(interp);
+	    pkgPtr = FindPackage(interp, name);
+	    break;
+	}
+
+	/*
+	 * Package not in the database.  If there is a "package unknown"
+	 * command, invoke it (but only on the first pass;  after that,
+	 * we should not get here in the first place).
+	 */
+
+	if (pass > 1) {
+	    break;
+	}
+	script = ((Interp *) interp)->packageUnknown;
+	if (script != NULL) {
+	    Tcl_DStringInit(&command);
+	    Tcl_DStringAppend(&command, script, -1);
+	    Tcl_DStringAppendElement(&command, name);
+	    Tcl_DStringAppend(&command, " ", 1);
+	    Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
+		    -1);
+	    if (exact) {
+		Tcl_DStringAppend(&command, " -exact", 7);
+	    }
+	    code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command));
+	    Tcl_DStringFree(&command);
+	    if (code != TCL_OK) {
+		if (code == TCL_ERROR) {
+		    Tcl_AddErrorInfo(interp,
+			    "\n    (\"package unknown\" script)");
+		}
+		return NULL;
+	    }
+	    Tcl_ResetResult(interp);
+	}
+    }
+
+    if (pkgPtr->version == NULL) {
+	Tcl_AppendResult(interp, "can't find package ", name,
+		(char *) NULL);
+	if (version != NULL) {
+	    Tcl_AppendResult(interp, " ", version, (char *) NULL);
+	}
+	return NULL;
+    }
+
+    /*
+     * At this point we now that the package is present.  Make sure that the
+     * provided version meets the current requirement.
+     */
+
+    if (version == NULL) {
+	return pkgPtr->version;
+    }
+    result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
+    if ((satisfies && !exact) || (result == 0)) {
+	return pkgPtr->version;
+    }
+    Tcl_AppendResult(interp, "version conflict for package \"",
+	    name, "\": have ", pkgPtr->version, ", need ", version,
+	    (char *) NULL);
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_PackageCmd --
+ *
+ *	This procedure is invoked to process the "package" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_PackageCmd(dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    Interp *iPtr = (Interp *) interp;
+    size_t length;
+    int c, exact, i, satisfies;
+    PkgAvail *availPtr, *prevPtr;
+    Package *pkgPtr;
+    Tcl_HashEntry *hPtr;
+    Tcl_HashSearch search;
+    Tcl_HashTable *tablePtr;
+    char *version;
+
+    if (argc < 2) {
+	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		" option ?arg arg ...?\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    c = argv[1][0];
+    length = strlen(argv[1]);
+    if ((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) {
+	for (i = 2; i < argc; i++) {
+	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[i]);
+	    if (hPtr == NULL) {
+		return TCL_OK;
+	    }
+	    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+	    Tcl_DeleteHashEntry(hPtr);
+	    if (pkgPtr->version != NULL) {
+		ckfree(pkgPtr->version);
+	    }
+	    while (pkgPtr->availPtr != NULL) {
+		availPtr = pkgPtr->availPtr;
+		pkgPtr->availPtr = availPtr->nextPtr;
+		ckfree(availPtr->version);
+		Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
+		ckfree((char *) availPtr);
+	    }
+	    ckfree((char *) pkgPtr);
+	}
+    } else if ((c == 'i') && (strncmp(argv[1], "ifneeded", length) == 0)) {
+	if ((argc != 4) && (argc != 5)) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " ifneeded package version ?script?\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	if (CheckVersion(interp, argv[3]) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (argc == 4) {
+	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
+	    if (hPtr == NULL) {
+		return TCL_OK;
+	    }
+	    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+	} else {
+	    pkgPtr = FindPackage(interp, argv[2]);
+	}
+	for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
+		prevPtr = availPtr, availPtr = availPtr->nextPtr) {
+	    if (ComparePkgVersions(availPtr->version, argv[3], (int *) NULL)
+		    == 0) {
+		if (argc == 4) {
+		    interp->result = availPtr->script;
+		    return TCL_OK;
+		}
+		Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
+		break;
+	    }
+	}
+	if (argc == 4) {
+	    return TCL_OK;
+	}
+	if (availPtr == NULL) {
+	    availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
+	    availPtr->version = ckalloc((unsigned) (strlen(argv[3]) + 1));
+	    strcpy(availPtr->version, argv[3]);
+	    if (prevPtr == NULL) {
+		availPtr->nextPtr = pkgPtr->availPtr;
+		pkgPtr->availPtr = availPtr;
+	    } else {
+		availPtr->nextPtr = prevPtr->nextPtr;
+		prevPtr->nextPtr = availPtr;
+	    }
+	}
+	availPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1));
+	strcpy(availPtr->script, argv[4]);
+    } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) {
+	if (argc != 2) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " names\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	tablePtr = &iPtr->packageTable;
+	for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
+		hPtr = Tcl_NextHashEntry(&search)) {
+	    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+	    if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
+		Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
+	    }
+	}
+    } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0)) {
+	if ((argc != 3) && (argc != 4)) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " provide package ?version?\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	if (argc == 3) {
+	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
+	    if (hPtr != NULL) {
+		pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+		if (pkgPtr->version != NULL) {
+		    interp->result = pkgPtr->version;
+		}
+	    }
+	    return TCL_OK;
+	}
+	if (CheckVersion(interp, argv[3]) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	return Tcl_PkgProvide(interp, argv[2], argv[3]);
+    } else if ((c == 'r') && (strncmp(argv[1], "require", length) == 0)) {
+	if (argc < 3) {
+	    requireSyntax:
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " require ?-exact? package ?version?\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) {
+	    exact = 1;
+	} else {
+	    exact = 0;
+	}
+	version = NULL;
+	if (argc == (4+exact)) {
+	    version = argv[3+exact];
+	    if (CheckVersion(interp, version) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	} else if ((argc != 3) || exact) {
+	    goto requireSyntax;
+	}
+	version = Tcl_PkgRequire(interp, argv[2+exact], version, exact);
+	if (version == NULL) {
+	    return TCL_ERROR;
+	}
+	interp->result = version;
+    } else if ((c == 'u') && (strncmp(argv[1], "unknown", length) == 0)) {
+	if (argc == 2) {
+	    if (iPtr->packageUnknown != NULL) {
+		iPtr->result = iPtr->packageUnknown;
+	    }
+	} else if (argc == 3) {
+	    if (iPtr->packageUnknown != NULL) {
+		ckfree(iPtr->packageUnknown);
+	    }
+	    if (argv[2][0] == 0) {
+		iPtr->packageUnknown = NULL;
+	    } else {
+		iPtr->packageUnknown = (char *) ckalloc((unsigned)
+			(strlen(argv[2]) + 1));
+		strcpy(iPtr->packageUnknown, argv[2]);
+	    }
+	} else {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " unknown ?command?\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+    } else if ((c == 'v') && (strncmp(argv[1], "vcompare", length) == 0)
+	    && (length >= 2)) {
+	if (argc != 4) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " vcompare version1 version2\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	if ((CheckVersion(interp, argv[2]) != TCL_OK)
+		|| (CheckVersion(interp, argv[3]) != TCL_OK)) {
+	    return TCL_ERROR;
+	}
+	sprintf(interp->result, "%d", ComparePkgVersions(argv[2], argv[3],
+		(int *) NULL));
+    } else if ((c == 'v') && (strncmp(argv[1], "versions", length) == 0)
+	    && (length >= 2)) {
+	if (argc != 3) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " versions package\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
+	if (hPtr != NULL) {
+	    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+	    for (availPtr = pkgPtr->availPtr; availPtr != NULL;
+		    availPtr = availPtr->nextPtr) {
+		Tcl_AppendElement(interp, availPtr->version);
+	    }
+	}
+    } else if ((c == 'v') && (strncmp(argv[1], "vsatisfies", length) == 0)
+	    && (length >= 2)) {
+	if (argc != 4) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " vsatisfies version1 version2\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	if ((CheckVersion(interp, argv[2]) != TCL_OK)
+		|| (CheckVersion(interp, argv[3]) != TCL_OK)) {
+	    return TCL_ERROR;
+	}
+	ComparePkgVersions(argv[2], argv[3], &satisfies);
+	sprintf(interp->result, "%d", satisfies);
+    } else {
+	Tcl_AppendResult(interp, "bad option \"", argv[1],
+		"\": should be forget, ifneeded, names, ",
+		"provide, require, unknown, vcompare, ",
+		"versions, or vsatisfies", (char *) NULL);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FindPackage --
+ *
+ *	This procedure finds the Package record for a particular package
+ *	in a particular interpreter, creating a record if one doesn't
+ *	already exist.
+ *
+ * Results:
+ *	The return value is a pointer to the Package record for the
+ *	package.
+ *
+ * Side effects:
+ *	A new Package record may be created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Package *
+FindPackage(interp, name)
+    Tcl_Interp *interp;		/* Interpreter to use for package lookup. */
+    char *name;			/* Name of package to fine. */
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_HashEntry *hPtr;
+    int new;
+    Package *pkgPtr;
+
+    hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new);
+    if (new) {
+	pkgPtr = (Package *) ckalloc(sizeof(Package));
+	pkgPtr->version = NULL;
+	pkgPtr->availPtr = NULL;
+	Tcl_SetHashValue(hPtr, pkgPtr);
+    } else {
+	pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+    }
+    return pkgPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFreePackageInfo --
+ *
+ *	This procedure is called during interpreter deletion to
+ *	free all of the package-related information for the
+ *	interpreter.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Memory is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFreePackageInfo(iPtr)
+    Interp *iPtr;		/* Interpereter that is being deleted. */
+{
+    Package *pkgPtr;
+    Tcl_HashSearch search;
+    Tcl_HashEntry *hPtr;
+    PkgAvail *availPtr;
+
+    for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
+	    hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
+	pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+	if (pkgPtr->version != NULL) {
+	    ckfree(pkgPtr->version);
+	}
+	while (pkgPtr->availPtr != NULL) {
+	    availPtr = pkgPtr->availPtr;
+	    pkgPtr->availPtr = availPtr->nextPtr;
+	    ckfree(availPtr->version);
+	    Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
+	    ckfree((char *) availPtr);
+	}
+	ckfree((char *) pkgPtr);
+    }
+    Tcl_DeleteHashTable(&iPtr->packageTable);
+    if (iPtr->packageUnknown != NULL) {
+	ckfree(iPtr->packageUnknown);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CheckVersion --
+ *
+ *	This procedure checks to see whether a version number has
+ *	valid syntax.
+ *
+ * Results:
+ *	If string is a properly formed version number the TCL_OK
+ *	is returned.  Otherwise TCL_ERROR is returned and an error
+ *	message is left in interp->result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CheckVersion(interp, string)
+    Tcl_Interp *interp;		/* Used for error reporting. */
+    char *string;		/* Supposedly a version number, which is
+				 * groups of decimal digits separated
+				 * by dots. */
+{
+    char *p = string;
+
+    if (!isdigit(*p)) {
+	goto error;
+    }
+    for (p++; *p != 0; p++) {
+	if (!isdigit(*p) && (*p != '.')) {
+	    goto error;
+	}
+    }
+    if (p[-1] != '.') {
+	return TCL_OK;
+    }
+
+    error:
+    Tcl_AppendResult(interp, "expected version number but got \"",
+	    string, "\"", (char *) NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ComparePkgVersions --
+ *
+ *	This procedure compares two version numbers.
+ *
+ * Results:
+ *	The return value is -1 if v1 is less than v2, 0 if the two
+ *	version numbers are the same, and 1 if v1 is greater than v2.
+ *	If *satPtr is non-NULL, the word it points to is filled in
+ *	with 1 if v2 >= v1 and both numbers have the same major number
+ *	or 0 otherwise.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ComparePkgVersions(v1, v2, satPtr)
+    char *v1, *v2;		/* Versions strings, of form 2.1.3 (any
+				 * number of version numbers). */
+    int *satPtr;		/* If non-null, the word pointed to is
+				 * filled in with a 0/1 value.  1 means
+				 * v1 "satisfies" v2:  v1 is greater than
+				 * or equal to v2 and both version numbers
+				 * have the same major number. */
+{
+    int thisIsMajor, n1, n2;
+
+    /*
+     * Each iteration of the following loop processes one number from
+     * each string, terminated by a ".".  If those numbers don't match
+     * then the comparison is over;  otherwise, we loop back for the
+     * next number.
+     */
+
+    thisIsMajor = 1;
+    while (1) {
+	/*
+	 * Parse one decimal number from the front of each string.
+	 */
+
+	n1 = n2 = 0;
+	while ((*v1 != 0) && (*v1 != '.')) {
+	    n1 = 10*n1 + (*v1 - '0');
+	    v1++;
+	}
+	while ((*v2 != 0) && (*v2 != '.')) {
+	    n2 = 10*n2 + (*v2 - '0');
+	    v2++;
+	}
+
+	/*
+	 * Compare and go on to the next version number if the
+	 * current numbers match.
+	 */
+
+	if (n1 != n2) {
+	    break;
+	}
+	if (*v1 != 0) {
+	    v1++;
+	} else if (*v2 == 0) {
+	    break;
+	}
+	if (*v2 != 0) {
+	    v2++;
+	}
+	thisIsMajor = 0;
+    }
+    if (satPtr != NULL) {
+	*satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
+    }
+    if (n1 > n2) {
+	return 1;
+    } else if (n1 == n2) {
+	return 0;
+    } else {
+	return -1;
+    }
+}

cde/programs/dtdocbook/tcl/tclPort.h

@@ -0,0 +1,30 @@
+/* $XConsortium: tclPort.h /main/2 1996/08/08 14:46:02 cde-hp $ */
+/*
+ * tclPort.h --
+ *
+ *	This header file handles porting issues that occur because
+ *	of differences between systems.  It reads in platform specific
+ *	portability files.
+ *
+ * Copyright (c) 1994-1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclPort.h 1.15 96/02/07 17:24:21
+ */
+
+#ifndef _TCLPORT
+#define _TCLPORT
+
+#if defined(__WIN32__) || defined(_WIN32)
+#   include "../win/tclWinPort.h"
+#else
+#   if defined(MAC_TCL)
+#	include "tclMacPort.h"
+#    else
+#	include "tclUnixPort.h"
+#    endif
+#endif
+
+#endif /* _TCLPORT */

cde/programs/dtdocbook/tcl/tclPreserve.c

@@ -0,0 +1,276 @@
+/* $XConsortium: tclPreserve.c /main/2 1996/08/08 14:46:12 cde-hp $ */
+/* 
+ * tclPreserve.c --
+ *
+ *	This file contains a collection of procedures that are used
+ *	to make sure that widget records and other data structures
+ *	aren't reallocated when there are nested procedures that
+ *	depend on their existence.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1995 Sun Microsystems, Inc.
+ *
+ * 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
+ */
+
+#include "tclInt.h"
+
+/*
+ * The following data structure is used to keep track of all the
+ * Tcl_Preserve calls that are still in effect.  It grows as needed
+ * to accommodate any number of calls in effect.
+ */
+
+typedef struct {
+    ClientData clientData;	/* Address of preserved block. */
+    int refCount;		/* Number of Tcl_Preserve calls in effect
+				 * for block. */
+    int mustFree;		/* Non-zero means Tcl_EventuallyFree was
+				 * called while a Tcl_Preserve call was in
+				 * effect, so the structure must be freed
+				 * when refCount becomes zero. */
+    Tcl_FreeProc *freeProc;	/* Procedure to call to free. */
+} Reference;
+
+static Reference *refArray;	/* First in array of references. */
+static int spaceAvl = 0;	/* Total number of structures available
+				 * at *firstRefPtr. */
+static int inUse = 0;		/* Count of structures currently in use
+				 * in refArray. */
+#define INITIAL_SIZE 2
+
+/*
+ * Static routines in this file:
+ */
+
+static void	PreserveExitProc _ANSI_ARGS_((ClientData clientData));
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PreserveExitProc --
+ *
+ *	Called during exit processing to clean up the reference array.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Frees the storage of the reference array.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static void
+PreserveExitProc(clientData)
+    ClientData clientData;		/* NULL -Unused. */
+{
+    if (spaceAvl != 0) {
+        ckfree((char *) refArray);
+        refArray = (Reference *) NULL;
+        inUse = 0;
+        spaceAvl = 0;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Preserve --
+ *
+ *	This procedure is used by a procedure to declare its interest
+ *	in a particular block of memory, so that the block will not be
+ *	reallocated until a matching call to Tcl_Release has been made.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Information is retained so that the block of memory will
+ *	not be freed until at least the matching call to Tcl_Release.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_Preserve(clientData)
+    ClientData clientData;	/* Pointer to malloc'ed block of memory. */
+{
+    Reference *refPtr;
+    int i;
+
+    /*
+     * See if there is already a reference for this pointer.  If so,
+     * just increment its reference count.
+     */
+
+    for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
+	if (refPtr->clientData == clientData) {
+	    refPtr->refCount++;
+	    return;
+	}
+    }
+
+    /*
+     * Make a reference array if it doesn't already exist, or make it
+     * bigger if it is full.
+     */
+
+    if (inUse == spaceAvl) {
+	if (spaceAvl == 0) {
+            Tcl_CreateExitHandler((Tcl_ExitProc *) PreserveExitProc,
+                    (ClientData) NULL);
+	    refArray = (Reference *) ckalloc((unsigned)
+		    (INITIAL_SIZE*sizeof(Reference)));
+	    spaceAvl = INITIAL_SIZE;
+	} else {
+	    Reference *new;
+
+	    new = (Reference *) ckalloc((unsigned)
+		    (2*spaceAvl*sizeof(Reference)));
+	    memcpy((VOID *) new, (VOID *) refArray,
+                    spaceAvl*sizeof(Reference));
+	    ckfree((char *) refArray);
+	    refArray = new;
+	    spaceAvl *= 2;
+	}
+    }
+
+    /*
+     * Make a new entry for the new reference.
+     */
+
+    refPtr = &refArray[inUse];
+    refPtr->clientData = clientData;
+    refPtr->refCount = 1;
+    refPtr->mustFree = 0;
+    inUse += 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Release --
+ *
+ *	This procedure is called to cancel a previous call to
+ *	Tcl_Preserve, thereby allowing a block of memory to be
+ *	freed (if no one else cares about it).
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	If Tcl_EventuallyFree has been called for clientData, and if
+ *	no other call to Tcl_Preserve is still in effect, the block of
+ *	memory is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_Release(clientData)
+    ClientData clientData;	/* Pointer to malloc'ed block of memory. */
+{
+    Reference *refPtr;
+    int mustFree;
+    Tcl_FreeProc *freeProc;
+    int i;
+
+    for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
+	if (refPtr->clientData != clientData) {
+	    continue;
+	}
+	refPtr->refCount--;
+	if (refPtr->refCount == 0) {
+
+            /*
+             * Must remove information from the slot before calling freeProc
+             * to avoid reentrancy problems if the freeProc calls Tcl_Preserve
+             * on the same clientData. Copy down the last reference in the
+             * array to overwrite the current slot.
+             */
+
+            freeProc = refPtr->freeProc;
+            mustFree = refPtr->mustFree;
+	    inUse--;
+	    if (i < inUse) {
+		refArray[i] = refArray[inUse];
+	    }
+	    if (mustFree) {
+		if ((freeProc == TCL_DYNAMIC) ||
+                        (freeProc == (Tcl_FreeProc *) free)) {
+		    ckfree((char *) clientData);
+		} else {
+		    (*freeProc)((char *) clientData);
+		}
+	    }
+	}
+	return;
+    }
+
+    /*
+     * Reference not found.  This is a bug in the caller.
+     */
+
+    panic("Tcl_Release couldn't find reference for 0x%x", clientData);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_EventuallyFree --
+ *
+ *	Free up a block of memory, unless a call to Tcl_Preserve is in
+ *	effect for that block.  In this case, defer the free until all
+ *	calls to Tcl_Preserve have been undone by matching calls to
+ *	Tcl_Release.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Ptr may be released by calling free().
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_EventuallyFree(clientData, freeProc)
+    ClientData clientData;	/* Pointer to malloc'ed block of memory. */
+    Tcl_FreeProc *freeProc;	/* Procedure to actually do free. */
+{
+    Reference *refPtr;
+    int i;
+
+    /*
+     * See if there is a reference for this pointer.  If so, set its
+     * "mustFree" flag (the flag had better not be set already!).
+     */
+
+    for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
+	if (refPtr->clientData != clientData) {
+	    continue;
+	}
+	if (refPtr->mustFree) {
+	    panic("Tcl_EventuallyFree called twice for 0x%x\n", clientData);
+        }
+        refPtr->mustFree = 1;
+	refPtr->freeProc = freeProc;
+        return;
+    }
+
+    /*
+     * No reference for this block.  Free it now.
+     */
+
+    if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) {
+	ckfree((char *) clientData);
+    } else {
+	(*freeProc)((char *)clientData);
+    }
+}

cde/programs/dtdocbook/tcl/tclProc.c

@@ -0,0 +1,659 @@
+/* $XConsortium: tclProc.c /main/2 1996/08/08 14:46:17 cde-hp $ */
+/* 
+ * tclProc.c --
+ *
+ *	This file contains routines that implement Tcl procedures,
+ *	including the "proc" and "uplevel" commands.
+ *
+ * Copyright (c) 1987-1993 The Regents of the University of California.
+ * Copyright (c) 1994-1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclProc.c 1.72 96/02/15 11:42:48
+ */
+
+#include "tclInt.h"
+
+/*
+ * Forward references to procedures defined later in this file:
+ */
+
+static void	CleanupProc _ANSI_ARGS_((Proc *procPtr));
+static  int	InterpProc _ANSI_ARGS_((ClientData clientData,
+		    Tcl_Interp *interp, int argc, char **argv));
+static  void	ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ProcCmd --
+ *
+ *	This procedure is invoked to process the "proc" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result value.
+ *
+ * Side effects:
+ *	A new procedure gets created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_ProcCmd(dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    register Interp *iPtr = (Interp *) interp;
+    register Proc *procPtr;
+    int result, argCount, i;
+    char **argArray = NULL;
+    Arg *lastArgPtr;
+    register Arg *argPtr = NULL;	/* Initialization not needed, but
+					 * prevents compiler warning. */
+
+    if (argc != 4) {
+	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		" name args body\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    procPtr = (Proc *) ckalloc(sizeof(Proc));
+    procPtr->iPtr = iPtr;
+    procPtr->refCount = 1;
+    procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
+    strcpy(procPtr->command, argv[3]);
+    procPtr->argPtr = NULL;
+
+    /*
+     * Break up the argument list into argument specifiers, then process
+     * each argument specifier.
+     */
+
+    result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
+    if (result != TCL_OK) {
+	goto procError;
+    }
+    lastArgPtr = NULL;
+    for (i = 0; i < argCount; i++) {
+	int fieldCount, nameLength, valueLength;
+	char **fieldValues;
+
+	/*
+	 * Now divide the specifier up into name and default.
+	 */
+
+	result = Tcl_SplitList(interp, argArray[i], &fieldCount,
+		&fieldValues);
+	if (result != TCL_OK) {
+	    goto procError;
+	}
+	if (fieldCount > 2) {
+	    ckfree((char *) fieldValues);
+	    Tcl_AppendResult(interp,
+		    "too many fields in argument specifier \"",
+		    argArray[i], "\"", (char *) NULL);
+	    result = TCL_ERROR;
+	    goto procError;
+	}
+	if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
+	    ckfree((char *) fieldValues);
+	    Tcl_AppendResult(interp, "procedure \"", argv[1],
+		    "\" has argument with no name", (char *) NULL);
+	    result = TCL_ERROR;
+	    goto procError;
+	}
+	nameLength = strlen(fieldValues[0]) + 1;
+	if (fieldCount == 2) {
+	    valueLength = strlen(fieldValues[1]) + 1;
+	} else {
+	    valueLength = 0;
+	}
+	argPtr = (Arg *) ckalloc((unsigned)
+		(sizeof(Arg) - sizeof(argPtr->name) + nameLength
+		+ valueLength));
+	if (lastArgPtr == NULL) {
+	    procPtr->argPtr = argPtr;
+	} else {
+	    lastArgPtr->nextPtr = argPtr;
+	}
+	lastArgPtr = argPtr;
+	argPtr->nextPtr = NULL;
+	strcpy(argPtr->name, fieldValues[0]);
+	if (fieldCount == 2) {
+	    argPtr->defValue = argPtr->name + nameLength;
+	    strcpy(argPtr->defValue, fieldValues[1]);
+	} else {
+	    argPtr->defValue = NULL;
+	}
+	ckfree((char *) fieldValues);
+    }
+
+    Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
+	    ProcDeleteProc);
+    ckfree((char *) argArray);
+    return TCL_OK;
+
+    procError:
+    ckfree(procPtr->command);
+    while (procPtr->argPtr != NULL) {
+	argPtr = procPtr->argPtr;
+	procPtr->argPtr = argPtr->nextPtr;
+	ckfree((char *) argPtr);
+    }
+    ckfree((char *) procPtr);
+    if (argArray != NULL) {
+	ckfree((char *) argArray);
+    }
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetFrame --
+ *
+ *	Given a description of a procedure frame, such as the first
+ *	argument to an "uplevel" or "upvar" command, locate the
+ *	call frame for the appropriate level of procedure.
+ *
+ * Results:
+ *	The return value is -1 if an error occurred in finding the
+ *	frame (in this case an error message is left in interp->result).
+ *	1 is returned if string was either a number or a number preceded
+ *	by "#" and it specified a valid frame.  0 is returned if string
+ *	isn't one of the two things above (in this case, the lookup
+ *	acts as if string were "1").  The variable pointed to by
+ *	framePtrPtr is filled in with the address of the desired frame
+ *	(unless an error occurs, in which case it isn't modified).
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGetFrame(interp, string, framePtrPtr)
+    Tcl_Interp *interp;		/* Interpreter in which to find frame. */
+    char *string;		/* String describing frame. */
+    CallFrame **framePtrPtr;	/* Store pointer to frame here (or NULL
+				 * if global frame indicated). */
+{
+    register Interp *iPtr = (Interp *) interp;
+    int curLevel, level, result;
+    CallFrame *framePtr;
+
+    /*
+     * Parse string to figure out which level number to go to.
+     */
+
+    result = 1;
+    curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
+    if (*string == '#') {
+	if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
+	    return -1;
+	}
+	if (level < 0) {
+	    levelError:
+	    Tcl_AppendResult(interp, "bad level \"", string, "\"",
+		    (char *) NULL);
+	    return -1;
+	}
+    } else if (isdigit(UCHAR(*string))) {
+	if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
+	    return -1;
+	}
+	level = curLevel - level;
+    } else {
+	level = curLevel - 1;
+	result = 0;
+    }
+
+    /*
+     * Figure out which frame to use, and modify the interpreter so
+     * its variables come from that frame.
+     */
+
+    if (level == 0) {
+	framePtr = NULL;
+    } else {
+	for (framePtr = iPtr->varFramePtr; framePtr != NULL;
+		framePtr = framePtr->callerVarPtr) {
+	    if (framePtr->level == level) {
+		break;
+	    }
+	}
+	if (framePtr == NULL) {
+	    goto levelError;
+	}
+    }
+    *framePtrPtr = framePtr;
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UplevelCmd --
+ *
+ *	This procedure is invoked to process the "uplevel" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result value.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_UplevelCmd(dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    register Interp *iPtr = (Interp *) interp;
+    int result;
+    CallFrame *savedVarFramePtr, *framePtr;
+
+    if (argc < 2) {
+	uplevelSyntax:
+	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		" ?level? command ?arg ...?\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Find the level to use for executing the command.
+     */
+
+    result = TclGetFrame(interp, argv[1], &framePtr);
+    if (result == -1) {
+	return TCL_ERROR;
+    }
+    argc -= (result+1);
+    if (argc == 0) {
+	goto uplevelSyntax;
+    }
+    argv += (result+1);
+
+    /*
+     * Modify the interpreter state to execute in the given frame.
+     */
+
+    savedVarFramePtr = iPtr->varFramePtr;
+    iPtr->varFramePtr = framePtr;
+
+    /*
+     * Execute the residual arguments as a command.
+     */
+
+    if (argc == 1) {
+	result = Tcl_Eval(interp, argv[0]);
+    } else {
+	char *cmd;
+
+	cmd = Tcl_Concat(argc, argv);
+	result = Tcl_Eval(interp, cmd);
+	ckfree(cmd);
+    }
+    if (result == TCL_ERROR) {
+	char msg[60];
+	sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
+	Tcl_AddErrorInfo(interp, msg);
+    }
+
+    /*
+     * Restore the variable frame, and return.
+     */
+
+    iPtr->varFramePtr = savedVarFramePtr;
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFindProc --
+ *
+ *	Given the name of a procedure, return a pointer to the
+ *	record describing the procedure.
+ *
+ * Results:
+ *	NULL is returned if the name doesn't correspond to any
+ *	procedure.  Otherwise the return value is a pointer to
+ *	the procedure's record.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Proc *
+TclFindProc(iPtr, procName)
+    Interp *iPtr;		/* Interpreter in which to look. */
+    char *procName;		/* Name of desired procedure. */
+{
+    Tcl_HashEntry *hPtr;
+    Command *cmdPtr;
+
+    hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
+    if (hPtr == NULL) {
+	return NULL;
+    }
+    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+    if (cmdPtr->proc != InterpProc) {
+	return NULL;
+    }
+    return (Proc *) cmdPtr->clientData;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclIsProc --
+ *
+ *	Tells whether a command is a Tcl procedure or not.
+ *
+ * Results:
+ *	If the given command is actuall a Tcl procedure, the
+ *	return value is the address of the record describing
+ *	the procedure.  Otherwise the return value is 0.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Proc *
+TclIsProc(cmdPtr)
+    Command *cmdPtr;		/* Command to test. */
+{
+    if (cmdPtr->proc == InterpProc) {
+	return (Proc *) cmdPtr->clientData;
+    }
+    return (Proc *) 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InterpProc --
+ *
+ *	When a Tcl procedure gets invoked, this routine gets invoked
+ *	to interpret the procedure.
+ *
+ * Results:
+ *	A standard Tcl result value, usually TCL_OK.
+ *
+ * Side effects:
+ *	Depends on the commands in the procedure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InterpProc(clientData, interp, argc, argv)
+    ClientData clientData;	/* Record describing procedure to be
+				 * interpreted. */
+    Tcl_Interp *interp;		/* Interpreter in which procedure was
+				 * invoked. */
+    int argc;			/* Count of number of arguments to this
+				 * procedure. */
+    char **argv;		/* Argument values. */
+{
+    register Proc *procPtr = (Proc *) clientData;
+    register Arg *argPtr;
+    register Interp *iPtr;
+    char **args;
+    CallFrame frame;
+    char *value;
+    int result;
+
+    /*
+     * Set up a call frame for the new procedure invocation.
+     */
+
+    iPtr = procPtr->iPtr;
+    Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
+    if (iPtr->varFramePtr != NULL) {
+	frame.level = iPtr->varFramePtr->level + 1;
+    } else {
+	frame.level = 1;
+    }
+    frame.argc = argc;
+    frame.argv = argv;
+    frame.callerPtr = iPtr->framePtr;
+    frame.callerVarPtr = iPtr->varFramePtr;
+    iPtr->framePtr = &frame;
+    iPtr->varFramePtr = &frame;
+    iPtr->returnCode = TCL_OK;
+
+    /*
+     * Match the actual arguments against the procedure's formal
+     * parameters to compute local variables.
+     */
+
+    for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
+	    argPtr != NULL;
+	    argPtr = argPtr->nextPtr, args++, argc--) {
+
+	/*
+	 * Handle the special case of the last formal being "args".  When
+	 * it occurs, assign it a list consisting of all the remaining
+	 * actual arguments.
+	 */
+
+	if ((argPtr->nextPtr == NULL)
+		&& (strcmp(argPtr->name, "args") == 0)) {
+	    if (argc < 0) {
+		argc = 0;
+	    }
+	    value = Tcl_Merge(argc, args);
+	    Tcl_SetVar(interp, argPtr->name, value, 0);
+	    ckfree(value);
+	    argc = 0;
+	    break;
+	} else if (argc > 0) {
+	    value = *args;
+	} else if (argPtr->defValue != NULL) {
+	    value = argPtr->defValue;
+	} else {
+	    Tcl_AppendResult(interp, "no value given for parameter \"",
+		    argPtr->name, "\" to \"", argv[0], "\"",
+		    (char *) NULL);
+	    result = TCL_ERROR;
+	    goto procDone;
+	}
+	Tcl_SetVar(interp, argPtr->name, value, 0);
+    }
+    if (argc > 0) {
+	Tcl_AppendResult(interp, "called \"", argv[0],
+		"\" with too many arguments", (char *) NULL);
+	result = TCL_ERROR;
+	goto procDone;
+    }
+
+    /*
+     * Invoke the commands in the procedure's body.
+     */
+
+    procPtr->refCount++;
+    result = Tcl_Eval(interp, procPtr->command);
+    procPtr->refCount--;
+    if (procPtr->refCount <= 0) {
+	CleanupProc(procPtr);
+    }
+    if (result == TCL_RETURN) {
+	result = TclUpdateReturnInfo(iPtr);
+    } else if (result == TCL_ERROR) {
+	char msg[100];
+
+	/*
+	 * Record information telling where the error occurred.
+	 */
+
+	sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],
+		iPtr->errorLine);
+	Tcl_AddErrorInfo(interp, msg);
+    } else if (result == TCL_BREAK) {
+	iPtr->result = "invoked \"break\" outside of a loop";
+	result = TCL_ERROR;
+    } else if (result == TCL_CONTINUE) {
+	iPtr->result = "invoked \"continue\" outside of a loop";
+	result = TCL_ERROR;
+    }
+
+    /*
+     * Delete the call frame for this procedure invocation (it's
+     * important to remove the call frame from the interpreter
+     * before deleting it, so that traces invoked during the
+     * deletion don't see the partially-deleted frame).
+     */
+
+    procDone:
+    iPtr->framePtr = frame.callerPtr;
+    iPtr->varFramePtr = frame.callerVarPtr;
+
+    /*
+     * The check below is a hack.  The problem is that there could be
+     * unset traces on the variables, which cause scripts to be evaluated.
+     * This will clear the ERR_IN_PROGRESS flag, losing stack trace
+     * information if the procedure was exiting with an error.  The
+     * code below preserves the flag.  Unfortunately, that isn't
+     * really enough:  we really should preserve the errorInfo variable
+     * too (otherwise a nested error in the trace script will trash
+     * errorInfo).  What's really needed is a general-purpose
+     * mechanism for saving and restoring interpreter state.
+     */
+
+    if (iPtr->flags & ERR_IN_PROGRESS) {
+	TclDeleteVars(iPtr, &frame.varTable);
+	iPtr->flags |= ERR_IN_PROGRESS;
+    } else {
+	TclDeleteVars(iPtr, &frame.varTable);
+    }
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ProcDeleteProc --
+ *
+ *	This procedure is invoked just before a command procedure is
+ *	removed from an interpreter.  Its job is to release all the
+ *	resources allocated to the procedure.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Memory gets freed, unless the procedure is actively being
+ *	executed.  In this case the cleanup is delayed until the
+ *	last call to the current procedure completes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ProcDeleteProc(clientData)
+    ClientData clientData;		/* Procedure to be deleted. */
+{
+    Proc *procPtr = (Proc *) clientData;
+
+    procPtr->refCount--;
+    if (procPtr->refCount <= 0) {
+	CleanupProc(procPtr);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CleanupProc --
+ *
+ *	This procedure does all the real work of freeing up a Proc
+ *	structure.  It's called only when the structure's reference
+ *	count becomes zero.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Memory gets freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+CleanupProc(procPtr)
+    register Proc *procPtr;		/* Procedure to be deleted. */
+{
+    register Arg *argPtr;
+
+    ckfree((char *) procPtr->command);
+    for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
+	Arg *nextPtr = argPtr->nextPtr;
+
+	ckfree((char *) argPtr);
+	argPtr = nextPtr;
+    }
+    ckfree((char *) procPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclUpdateReturnInfo --
+ *
+ *	This procedure is called when procedures return, and at other
+ *	points where the TCL_RETURN code is used.  It examines fields
+ *	such as iPtr->returnCode and iPtr->errorCode and modifies
+ *	the real return status accordingly.
+ *
+ * Results:
+ *	The return value is the true completion code to use for
+ *	the procedure, instead of TCL_RETURN.
+ *
+ * Side effects:
+ *	The errorInfo and errorCode variables may get modified.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclUpdateReturnInfo(iPtr)
+    Interp *iPtr;		/* Interpreter for which TCL_RETURN
+				 * exception is being processed. */
+{
+    int code;
+
+    code = iPtr->returnCode;
+    iPtr->returnCode = TCL_OK;
+    if (code == TCL_ERROR) {
+	Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL,
+		(iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
+		TCL_GLOBAL_ONLY);
+	iPtr->flags |= ERROR_CODE_SET;
+	if (iPtr->errorInfo != NULL) {
+	    Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL,
+		    iPtr->errorInfo, TCL_GLOBAL_ONLY);
+	    iPtr->flags |= ERR_IN_PROGRESS;
+	}
+    }
+    return code;
+}

cde/programs/dtdocbook/tcl/tclRegexp.h

@@ -0,0 +1,41 @@
+/* $XConsortium: tclRegexp.h /main/2 1996/08/08 14:46:22 cde-hp $ */
+/*
+ * Definitions etc. for regexp(3) routines.
+ *
+ * Caveat:  this is V8 regexp(3) [actually, a reimplementation thereof],
+ * not the System V one.
+ *
+ * SCCS: @(#) tclRegexp.h 1.6 96/04/02 18:43:57
+ */
+
+#ifndef _REGEXP
+#define _REGEXP 1
+
+#ifndef _TCL
+#include "tcl.h"
+#endif
+
+/*
+ * NSUBEXP must be at least 10, and no greater than 117 or the parser
+ * will not work properly.
+ */
+
+#define NSUBEXP  20
+
+typedef struct regexp {
+	char *startp[NSUBEXP];
+	char *endp[NSUBEXP];
+	char regstart;		/* Internal use only. */
+	char reganch;		/* Internal use only. */
+	char *regmust;		/* Internal use only. */
+	int regmlen;		/* Internal use only. */
+	char program[1];	/* Unwarranted chumminess with compiler. */
+} regexp;
+
+EXTERN regexp *TclRegComp _ANSI_ARGS_((char *exp));
+EXTERN int TclRegExec _ANSI_ARGS_((regexp *prog, char *string, char *start));
+EXTERN void TclRegSub _ANSI_ARGS_((regexp *prog, char *source, char *dest));
+EXTERN void TclRegError _ANSI_ARGS_((char *msg));
+EXTERN char *TclGetRegError _ANSI_ARGS_((void));
+
+#endif /* REGEXP */

cde/programs/dtdocbook/tcl/tclUnixFile.c

@@ -0,0 +1,763 @@
+/* $XConsortium: tclUnixFile.c /main/3 1996/10/03 17:18:17 drk $ */
+/* 
+ * tclUnixFile.c --
+ *
+ *      This file contains wrappers around UNIX file handling functions.
+ *      These wrappers mask differences between Windows and UNIX.
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclUnixFile.c 1.38 96/04/18 08:43:51
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * The variable below caches the name of the current working directory
+ * in order to avoid repeated calls to getcwd.  The string is malloc-ed.
+ * NULL means the cache needs to be refreshed.
+ */
+
+static char *currentDir =  NULL;
+static int currentDirExitHandlerSet = 0;
+
+/*
+ * The variable below is set if the exit routine for deleting the string
+ * containing the executable name has been registered.
+ */
+
+static int executableNameExitHandlerSet = 0;
+
+extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options));
+
+/*
+ * Static routines for this file:
+ */
+
+static void	FreeCurrentDir _ANSI_ARGS_((ClientData clientData));
+static void	FreeExecutableName _ANSI_ARGS_((ClientData clientData));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_WaitPid --
+ *
+ *	Implements the waitpid system call on Unix systems.
+ *
+ * Results:
+ *	Result of calling waitpid.
+ *
+ * Side effects:
+ *	Waits for a process to terminate.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_WaitPid(pid, statPtr, options)
+    pid_t pid;
+    int *statPtr;
+    int options;
+{
+    int result;
+    pid_t real_pid;
+
+    real_pid = (pid_t) pid;
+    while (1) {
+	result = (int) waitpid(real_pid, statPtr, options);
+	if ((result != -1) || (errno != EINTR)) {
+	    return result;
+	}
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeCurrentDir --
+ *
+ *	Frees the string stored in the currentDir variable. This routine
+ *	is registered as an exit handler and will be called during shutdown.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Frees the memory occuppied by the currentDir value.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static void
+FreeCurrentDir(clientData)
+    ClientData clientData;	/* Not used. */
+{
+    if (currentDir != (char *) NULL) {
+        ckfree(currentDir);
+        currentDir = (char *) NULL;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeExecutableName --
+ *
+ *	Frees the string stored in the tclExecutableName variable. This
+ *	routine is registered as an exit handler and will be called
+ *	during shutdown.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Frees the memory occuppied by the tclExecutableName value.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static void
+FreeExecutableName(clientData)
+    ClientData clientData;	/* Not used. */
+{
+    if (tclExecutableName != (char *) NULL) {
+        ckfree(tclExecutableName);
+        tclExecutableName = (char *) NULL;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChdir --
+ *
+ *	Change the current working directory.
+ *
+ * Results:
+ *	The result is a standard Tcl result.  If an error occurs and 
+ *	interp isn't NULL, an error message is left in interp->result.
+ *
+ * Side effects:
+ *	The working directory for this application is changed.  Also
+ *	the cache maintained used by TclGetCwd is deallocated and
+ *	set to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclChdir(interp, dirName)
+    Tcl_Interp *interp;		/* If non NULL, used for error reporting. */
+    char *dirName;     		/* Path to new working directory. */
+{
+    if (currentDir != NULL) {
+	ckfree(currentDir);
+	currentDir = NULL;
+    }
+    if (chdir(dirName) != 0) {
+	if (interp != NULL) {
+	    Tcl_AppendResult(interp, "couldn't change working directory to \"",
+		    dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
+	}
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetCwd --
+ *
+ *	Return the path name of the current working directory.
+ *
+ * Results:
+ *	The result is the full path name of the current working
+ *	directory, or NULL if an error occurred while figuring it out.
+ *	The returned string is owned by the TclGetCwd routine and must
+ *	not be freed by the caller.  If an error occurs and interp
+ *	isn't NULL, an error message is left in interp->result.
+ *
+ * Side effects:
+ *	The path name is cached to avoid having to recompute it
+ *	on future calls;  if it is already cached, the cached
+ *	value is returned.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclGetCwd(interp)
+    Tcl_Interp *interp;		/* If non NULL, used for error reporting. */
+{
+    char buffer[MAXPATHLEN+1];
+
+    if (currentDir == NULL) {
+        if (!currentDirExitHandlerSet) {
+            currentDirExitHandlerSet = 1;
+            Tcl_CreateExitHandler(FreeCurrentDir, (ClientData) NULL);
+        }
+	if (getcwd(buffer, MAXPATHLEN+1) == NULL) {
+	    if (interp != NULL) {
+		if (errno == ERANGE) {
+		    interp->result = "working directory name is too long";
+		} else {
+		    Tcl_AppendResult(interp,
+			    "error getting working directory name: ",
+			    Tcl_PosixError(interp), (char *) NULL);
+		}
+	    }
+	    return NULL;
+	}
+	currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1));
+	strcpy(currentDir, buffer);
+    }
+    return currentDir;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclOpenFile --
+ *
+ *	Implements a mechanism to open files on Unix systems.
+ *
+ * Results:
+ *	The opened file.
+ *
+ * Side effects:
+ *	May cause a file to be created on the file system.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_File
+TclOpenFile(fname, mode)
+    char *fname;			/* The name of the file to open. */
+    int mode;				/* In what mode to open the file? */
+{
+    int fd;
+
+    fd = open(fname, mode, 0600);
+    if (fd != -1) {
+        fcntl(fd, F_SETFD, FD_CLOEXEC);
+        return Tcl_GetFile((ClientData)fd, TCL_UNIX_FD);
+    }
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCloseFile --
+ *
+ *	Implements a mechanism to close a UNIX file.
+ *
+ * Results:
+ *	Returns 0 on success, or -1 on error, setting errno.
+ *
+ * Side effects:
+ *	The file is closed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCloseFile(file)
+    Tcl_File file;	/* The file to close. */
+{
+    int type;
+    int fd;
+    int result;
+
+    fd = (int) Tcl_GetFileInfo(file, &type);
+    if (type != TCL_UNIX_FD) {
+	panic("Tcl_CloseFile: unexpected file type");
+    }
+
+    /*
+     * Refuse to close the fds for stdin, stdout and stderr.
+     */
+    
+    if ((fd == 0) || (fd == 1) || (fd == 2)) {
+        return 0;
+    }
+    
+    result = close(fd);
+    Tcl_DeleteFileHandler(file);
+    Tcl_FreeFile(file);
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclReadFile --
+ *
+ *	Implements a mechanism to read from files on Unix systems. Also
+ *	simulates blocking behavior on non-blocking files when asked to.
+ *
+ * Results:
+ *	The number of characters read from the specified file.
+ *
+ * Side effects:
+ *	May consume characters from the file.
+ *
+ *----------------------------------------------------------------------
+ */
+	/* ARGSUSED */
+int
+TclReadFile(file, shouldBlock, buf, toRead)
+    Tcl_File file;	/* The file to read from. */
+    int shouldBlock;		/* Not used. */
+    char *buf;			/* The buffer to store input in. */
+    int toRead;			/* Number of characters to read. */
+{
+    int type, fd;
+
+    fd = (int) Tcl_GetFileInfo(file, &type);
+    if (type != TCL_UNIX_FD) {
+	panic("Tcl_ReadFile: unexpected file type");
+    }
+
+    return read(fd, buf, (size_t) toRead);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWriteFile --
+ *
+ *	Implements a mechanism to write to files on Unix systems.
+ *
+ * Results:
+ *	The number of characters written to the specified file.
+ *
+ * Side effects:
+ *	May produce characters on the file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+TclWriteFile(file, shouldBlock, buf, toWrite)
+    Tcl_File file;	/* The file to write to. */
+    int shouldBlock;		/* Not used. */
+    char *buf;			/* Where output is stored. */
+    int toWrite;		/* Number of characters to write. */
+{
+    int type, fd;
+
+    fd = (int) Tcl_GetFileInfo(file, &type);
+    if (type != TCL_UNIX_FD) {
+	panic("Tcl_WriteFile: unexpected file type");
+    }
+    return write(fd, buf, (size_t) toWrite);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSeekFile --
+ *
+ *	Sets the file pointer on the indicated UNIX file.
+ *
+ * Results:
+ *	The new position at which the file will be accessed, or -1 on
+ *	failure.
+ *
+ * Side effects:
+ *	May change the position at which subsequent operations access the
+ *	file designated by the file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclSeekFile(file, offset, whence)
+    Tcl_File file;	/* The file to seek on. */
+    int offset;			/* How far to seek? */
+    int whence;			/* And from where to seek? */
+{
+    int type, fd;
+
+    fd = (int) Tcl_GetFileInfo(file, &type);
+    if (type != TCL_UNIX_FD) {
+	panic("Tcl_SeekFile: unexpected file type");
+    }
+
+    return lseek(fd, offset, whence);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCreateTempFile --
+ *
+ *	This function creates a temporary file initialized with an
+ *	optional string, and returns a file handle with the file pointer
+ *	at the beginning of the file.
+ *
+ * Results:
+ *	A handle to a file.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_File
+TclCreateTempFile(contents)
+    char *contents;		/* String to write into temp file, or NULL. */
+{
+    char fileName[L_tmpnam];
+    Tcl_File file;
+    size_t length = (contents == NULL) ? 0 : strlen(contents);
+
+    tmpnam(fileName);
+    file = TclOpenFile(fileName, O_RDWR|O_CREAT|O_TRUNC);
+    unlink(fileName);
+
+    if ((file != NULL) && (length > 0)) {
+	int fd = (int)Tcl_GetFileInfo(file, NULL);
+	while (1) {
+	    if (write(fd, contents, length) != -1) {
+		break;
+	    } else if (errno != EINTR) {
+		close(fd);
+		Tcl_FreeFile(file);
+		return NULL;
+	    }
+	}
+	lseek(fd, 0, SEEK_SET);
+    }
+    return file;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FindExecutable --
+ *
+ *	This procedure computes the absolute path name of the current
+ *	application, given its argv[0] value.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The variable tclExecutableName gets filled in with the file
+ *	name for the application, if we figured it out.  If we couldn't
+ *	figure it out, Tcl_FindExecutable is set to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FindExecutable(argv0)
+    char *argv0;		/* The value of the application's argv[0]. */
+{
+    char *name, *p, *cwd;
+    Tcl_DString buffer;
+    int length;
+
+    Tcl_DStringInit(&buffer);
+    if (tclExecutableName != NULL) {
+	ckfree(tclExecutableName);
+	tclExecutableName = NULL;
+    }
+
+    name = argv0;
+    for (p = name; *p != 0; p++) {
+	if (*p == '/') {
+	    /*
+	     * The name contains a slash, so use the name directly
+	     * without doing a path search.
+	     */
+
+	    goto gotName;
+	}
+    }
+
+    p = getenv("PATH");
+    if (p == NULL) {
+	/*
+	 * There's no PATH environment variable; use the default that
+	 * is used by sh.
+	 */
+
+	p = ":/bin:/usr/bin";
+    }
+
+    /*
+     * Search through all the directories named in the PATH variable
+     * to see if argv[0] is in one of them.  If so, use that file
+     * name.
+     */
+
+    while (*p != 0) {
+	while (isspace(UCHAR(*p))) {
+	    p++;
+	}
+	name = p;
+	while ((*p != ':') && (*p != 0)) {
+	    p++;
+	}
+	Tcl_DStringSetLength(&buffer, 0);
+	if (p != name) {
+	    Tcl_DStringAppend(&buffer, name, p-name);
+	    if (p[-1] != '/') {
+		Tcl_DStringAppend(&buffer, "/", 1);
+	    }
+	}
+	Tcl_DStringAppend(&buffer, argv0, -1);
+	if (access(Tcl_DStringValue(&buffer), X_OK) == 0) {
+	    name = Tcl_DStringValue(&buffer);
+	    goto gotName;
+	}
+	p++;
+    }
+    goto done;
+
+    /*
+     * If the name starts with "/" then just copy it to tclExecutableName.
+     */
+
+    gotName:
+    if (name[0] == '/')  {
+	tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1));
+	strcpy(tclExecutableName, name);
+	goto done;
+    }
+
+    /*
+     * The name is relative to the current working directory.  First
+     * strip off a leading "./", if any, then add the full path name of
+     * the current working directory.
+     */
+
+    if ((name[0] == '.') && (name[1] == '/')) {
+	name += 2;
+    }
+    cwd = TclGetCwd((Tcl_Interp *) NULL);
+    if (cwd == NULL) {
+	tclExecutableName = NULL;
+	goto done;
+    }
+    length = strlen(cwd);
+    tclExecutableName = (char *) ckalloc((unsigned)
+	    (length + strlen(name) + 2));
+    strcpy(tclExecutableName, cwd);
+    tclExecutableName[length] = '/';
+    strcpy(tclExecutableName + length + 1, name);
+
+    done:
+    Tcl_DStringFree(&buffer);
+
+    if (!executableNameExitHandlerSet) {
+        executableNameExitHandlerSet = 1;
+        Tcl_CreateExitHandler(FreeExecutableName, (ClientData) NULL);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetUserHome --
+ *
+ *	This function takes the passed in user name and finds the
+ *	corresponding home directory specified in the password file.
+ *
+ * Results:
+ *	The result is a pointer to a static string containing
+ *	the new name.  If there was an error in processing the
+ *	user name then the return value is NULL.  Otherwise the
+ *	result is stored in bufferPtr, and the caller must call
+ *	Tcl_DStringFree(bufferPtr) to free the result.
+ *
+ * Side effects:
+ *	Information may be left in bufferPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclGetUserHome(name, bufferPtr)
+    char *name;			/* User name to use to find home directory. */
+    Tcl_DString *bufferPtr;	/* May be used to hold result.  Must not hold
+				 * anything at the time of the call, and need
+				 * not even be initialized. */
+{
+    struct passwd *pwPtr;
+
+    pwPtr = getpwnam(name);
+    if (pwPtr == NULL) {
+	endpwent();
+	return NULL;
+    }
+    Tcl_DStringInit(bufferPtr);
+    Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1);
+    endpwent();
+    return bufferPtr->string;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclMatchFiles --
+ *
+ *	This routine is used by the globbing code to search a
+ *	directory for all files which match a given pattern.
+ *
+ * Results: 
+ *	If the tail argument is NULL, then the matching files are
+ *	added to the interp->result.  Otherwise, TclDoGlob is called
+ *	recursively for each matching subdirectory.  The return value
+ *	is a standard Tcl result indicating whether an error occurred
+ *	in globbing.
+ *
+ * Side effects:
+ *	None.
+ *
+ *---------------------------------------------------------------------- */
+
+int
+TclMatchFiles(interp, separators, dirPtr, pattern, tail)
+    Tcl_Interp *interp;		/* Interpreter to receive results. */
+    char *separators;		/* Path separators to pass to TclDoGlob. */
+    Tcl_DString *dirPtr;	/* Contains path to directory to search. */
+    char *pattern;		/* Pattern to match against. */
+    char *tail;			/* Pointer to end of pattern. */
+{
+    char *dirName, *patternEnd = tail;
+    char savedChar = 0;		/* Initialization needed only to prevent
+				 * compiler warning from gcc. */
+    DIR *d;
+    struct stat statBuf;
+    struct dirent *entryPtr;
+    int matchHidden;
+    int result = TCL_OK;
+    int baseLength = Tcl_DStringLength(dirPtr);
+
+    /*
+     * Make sure that the directory part of the name really is a
+     * directory.  If the directory name is "", use the name "."
+     * instead, because some UNIX systems don't treat "" like "."
+     * automatically.  Keep the "" for use in generating file names,
+     * otherwise "glob foo.c" would return "./foo.c".
+     */
+
+    if (dirPtr->string[0] == '\0') {
+	dirName = ".";
+    } else {
+	dirName = dirPtr->string;
+    }
+    if ((stat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
+	return TCL_OK;
+    }
+
+    /*
+     * Check to see if the pattern needs to compare with hidden files.
+     */
+
+    if ((pattern[0] == '.')
+	    || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
+	matchHidden = 1;
+    } else {
+	matchHidden = 0;
+    }
+
+    /*
+     * Now open the directory for reading and iterate over the contents.
+     */
+
+    d = opendir(dirName);
+    if (d == NULL) {
+	Tcl_ResetResult(interp);
+
+	/*
+	 * Strip off a trailing '/' if necessary, before reporting the error.
+	 */
+
+	if (baseLength > 0) {
+	    savedChar = dirPtr->string[baseLength-1];
+	    if (savedChar == '/') {
+		dirPtr->string[baseLength-1] = '\0';
+	    }
+	}
+	Tcl_AppendResult(interp, "couldn't read directory \"",
+		dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL);
+	if (baseLength > 0) {
+	    dirPtr->string[baseLength-1] = savedChar;
+	}
+	return TCL_ERROR;
+    }
+
+    /*
+     * Clean up the end of the pattern and the tail pointer.  Leave
+     * the tail pointing to the first character after the path separator
+     * following the pattern, or NULL.  Also, ensure that the pattern
+     * is null-terminated.
+     */
+
+    if (*tail == '\\') {
+	tail++;
+    }
+    if (*tail == '\0') {
+	tail = NULL;
+    } else {
+	tail++;
+    }
+    savedChar = *patternEnd;
+    *patternEnd = '\0';
+
+    while (1) {
+	entryPtr = readdir(d);
+	if (entryPtr == NULL) {
+	    break;
+	}
+
+	/*
+	 * Don't match names starting with "." unless the "." is
+	 * present in the pattern.
+	 */
+
+	if (!matchHidden && (*entryPtr->d_name == '.')) {
+	    continue;
+	}
+
+	/*
+	 * Now check to see if the file matches.  If there are more
+	 * characters to be processed, then ensure matching files are
+	 * directories before calling TclDoGlob. Otherwise, just add
+	 * the file to the result.
+	 */
+
+	if (Tcl_StringMatch(entryPtr->d_name, pattern)) {
+	    Tcl_DStringSetLength(dirPtr, baseLength);
+	    Tcl_DStringAppend(dirPtr, entryPtr->d_name, -1);
+	    if (tail == NULL) {
+		Tcl_AppendElement(interp, dirPtr->string);
+	    } else if ((stat(dirPtr->string, &statBuf) == 0)
+		    && S_ISDIR(statBuf.st_mode)) {
+		Tcl_DStringAppend(dirPtr, "/", 1);
+		result = TclDoGlob(interp, separators, dirPtr, tail);
+		if (result != TCL_OK) {
+		    break;
+		}
+	    }
+	}
+    }
+    *patternEnd = savedChar;
+
+    closedir(d);
+    return result;
+}

cde/programs/dtdocbook/tcl/tclUnixInit.c

@@ -0,0 +1,164 @@
+/* $XConsortium: tclUnixInit.c /main/2 1996/08/08 14:46:42 cde-hp $ */
+/* 
+ * tclUnixInit.c --
+ *
+ *	Contains the Unix-specific interpreter initialization functions.
+ *
+ * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclUnixInit.c 1.10 96/03/12 09:05:59
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+#ifndef NO_UNAME
+#   include <sys/utsname.h>
+#endif
+#if defined(__FreeBSD__)
+#include <floatingpoint.h>
+#endif
+
+/*
+ * Default directory in which to look for libraries:
+ */
+
+static char defaultLibraryDir[200] = TCL_LIBRARY;
+
+/*
+ * The following string is the startup script executed in new
+ * interpreters.  It looks on disk in several different directories
+ * for a script "init.tcl" that is compatible with this version
+ * of Tcl.  The init.tcl script does all of the real work of
+ * initialization.
+ */
+
+static char *initScript =
+"proc init {} {\n\
+    global tcl_library tcl_version tcl_patchLevel env\n\
+    rename init {}\n\
+    set dirs {}\n\
+    if [info exists env(TCL_LIBRARY)] {\n\
+	lappend dirs $env(TCL_LIBRARY)\n\
+    }\n\
+    lappend dirs [info library]\n\
+    lappend dirs [file dirname [file dirname [info nameofexecutable]]]/lib/tcl$tcl_version\n\
+    if [string match {*[ab]*} $tcl_patchLevel] {\n\
+	set lib tcl$tcl_patchLevel\n\
+    } else {\n\
+	set lib tcl$tcl_version\n\
+    }\n\
+    lappend dirs [file dirname [file dirname [pwd]]]/$lib/library\n\
+    lappend dirs [file dirname [pwd]]/library\n\
+    foreach i $dirs {\n\
+	set tcl_library $i\n\
+	if ![catch {uplevel #0 source $i/init.tcl}] {\n\
+	    return\n\
+	}\n\
+    }\n\
+    set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
+    append msg \"    $dirs\n\"\n\
+    append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
+    error $msg\n\
+}\n\
+init";
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPlatformInit --
+ *
+ *	Performs Unix-specific interpreter initialization related to the
+ *      tcl_library and tcl_platform variables, and other platform-
+ *	specific things.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Sets "tcl_library" and "tcl_platform" Tcl variables.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPlatformInit(interp)
+    Tcl_Interp *interp;
+{
+#ifndef NO_UNAME
+    struct utsname name;
+#endif
+    int unameOK;
+    static int initialized = 0;
+
+    tclPlatform = TCL_PLATFORM_UNIX;
+    Tcl_SetVar(interp, "tcl_library", defaultLibraryDir, TCL_GLOBAL_ONLY);
+    Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
+    unameOK = 0;
+#ifndef NO_UNAME
+    if (uname(&name) >= 0) {
+	unameOK = 1;
+	Tcl_SetVar2(interp, "tcl_platform", "os", name.sysname,
+		TCL_GLOBAL_ONLY);
+	Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
+		TCL_GLOBAL_ONLY);
+	Tcl_SetVar2(interp, "tcl_platform", "machine", name.machine,
+		TCL_GLOBAL_ONLY);
+    }
+#endif
+    if (!unameOK) {
+	Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY);
+	Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY);
+	Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY);
+    }
+
+    if (!initialized) {
+	/*
+	 * The code below causes SIGPIPE (broken pipe) errors to
+	 * be ignored.  This is needed so that Tcl processes don't
+	 * die if they create child processes (e.g. using "exec" or
+	 * "open") that terminate prematurely.  The signal handler
+	 * is only set up when the first interpreter is created;
+	 * after this the application can override the handler with
+	 * a different one of its own, if it wants.
+	 */
+    
+#ifdef SIGPIPE
+	(void) signal(SIGPIPE, SIG_IGN);
+#endif /* SIGPIPE */
+
+#ifdef __FreeBSD__
+	fpsetround(FP_RN);
+	fpsetmask(0L);
+#endif
+	initialized = 1;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Init --
+ *
+ *	This procedure is typically invoked by Tcl_AppInit procedures
+ *	to perform additional initialization for a Tcl interpreter,
+ *	such as sourcing the "init.tcl" script.
+ *
+ * Results:
+ *	Returns a standard Tcl completion code and sets interp->result
+ *	if there is an error.
+ *
+ * Side effects:
+ *	Depends on what's in the init.tcl script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_Init(interp)
+    Tcl_Interp *interp;		/* Interpreter to initialize. */
+{
+    return Tcl_Eval(interp, initScript);
+}

cde/programs/dtdocbook/tcl/tclUnixNotfy.c

@@ -0,0 +1,324 @@
+/* $TOG: tclUnixNotfy.c /main/3 1998/04/06 13:37:34 mgreess $ */
+/* 
+ * tclUnixNotify.c --
+ *
+ *	This file contains Unix-specific procedures for the notifier,
+ *	which is the lowest-level part of the Tcl event loop.  This file
+ *	works together with ../generic/tclNotify.c.
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclUnixNotfy.c 1.30 96/03/22 12:45:31
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+#include <signal.h> 
+#include <sys/time.h> 
+
+/*
+ * The information below is used to provide read, write, and
+ * exception masks to select during calls to Tcl_DoOneEvent.
+ */
+
+static fd_mask checkMasks[3*MASK_SIZE];
+				/* This array is used to build up the masks
+				 * to be used in the next call to select.
+				 * Bits are set in response to calls to
+				 * Tcl_WatchFile. */
+static fd_mask readyMasks[3*MASK_SIZE];
+				/* This array reflects the readable/writable
+				 * conditions that were found to exist by the
+				 * last call to select. */
+static int numFdBits;		/* Number of valid bits in checkMasks
+				 * (one more than highest fd for which
+				 * Tcl_WatchFile has been called). */
+
+/*
+ * Static routines in this file:
+ */
+
+static int	MaskEmpty _ANSI_ARGS_((long *maskPtr));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_WatchFile --
+ *
+ *	Arrange for Tcl_DoOneEvent to include this file in the masks
+ *	for the next call to select.  This procedure is invoked by
+ *	event sources, which are in turn invoked by Tcl_DoOneEvent
+ *	before it invokes select.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	
+ *	The notifier will generate a file event when the I/O channel
+ *	given by fd next becomes ready in the way indicated by mask.
+ *	If fd is already registered then the old mask will be replaced
+ *	with the new one.  Once the event is sent, the notifier will
+ *	not send any more events about the fd until the next call to
+ *	Tcl_NotifyFile. 
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_WatchFile(file, mask)
+    Tcl_File file;	/* Generic file handle for a stream. */
+    int mask;			/* OR'ed combination of TCL_READABLE,
+				 * TCL_WRITABLE, and TCL_EXCEPTION:
+				 * indicates conditions to wait for
+				 * in select. */
+{
+    int fd, type, index;
+    fd_mask bit;
+
+    fd = (int) Tcl_GetFileInfo(file, &type);
+
+    if (type != TCL_UNIX_FD) {
+	panic("Tcl_WatchFile: unexpected file type");
+    }
+
+    if (fd >= FD_SETSIZE) {
+	panic("Tcl_WatchFile can't handle file id %d", fd);
+    }
+
+    index = fd/(NBBY*sizeof(fd_mask));
+    bit = 1 << (fd%(NBBY*sizeof(fd_mask)));
+    if (mask & TCL_READABLE) {
+	checkMasks[index] |= bit;
+    }
+    if (mask & TCL_WRITABLE) {
+	(checkMasks+MASK_SIZE)[index] |= bit;
+    }
+    if (mask & TCL_EXCEPTION) {
+	(checkMasks+2*(MASK_SIZE))[index] |= bit;
+    }
+    if (numFdBits <= fd) {
+	numFdBits = fd+1;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FileReady --
+ *
+ *	Indicates what conditions (readable, writable, etc.) were
+ *	present on a file the last time the notifier invoked select.
+ *	This procedure is typically invoked by event sources to see
+ *	if they should queue events.
+ *
+ * Results:
+ *	The return value is 0 if none of the conditions specified by mask
+ *	was true for fd the last time the system checked.  If any of the
+ *	conditions were true, then the return value is a mask of those
+ *	that were true.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FileReady(file, mask)
+    Tcl_File file;	/* Generic file handle for a stream. */
+    int mask;			/* OR'ed combination of TCL_READABLE,
+				 * TCL_WRITABLE, and TCL_EXCEPTION:
+				 * indicates conditions caller cares about. */
+{
+    int index, result, type, fd;
+    fd_mask bit;
+
+    fd = (int) Tcl_GetFileInfo(file, &type);
+    if (type != TCL_UNIX_FD) {
+	panic("Tcl_FileReady: unexpected file type");
+    }
+
+    index = fd/(NBBY*sizeof(fd_mask));
+    bit = 1 << (fd%(NBBY*sizeof(fd_mask)));
+    result = 0;
+    if ((mask & TCL_READABLE) && (readyMasks[index] & bit)) {
+	result |= TCL_READABLE;
+    }
+    if ((mask & TCL_WRITABLE) && ((readyMasks+MASK_SIZE)[index] & bit)) {
+	result |= TCL_WRITABLE;
+    }
+    if ((mask & TCL_EXCEPTION) && ((readyMasks+(2*MASK_SIZE))[index] & bit)) {
+	result |= TCL_EXCEPTION;
+    }
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MaskEmpty --
+ *
+ *	Returns nonzero if mask is empty (has no bits set).
+ *
+ * Results:
+ *	Nonzero if the mask is empty, zero otherwise.
+ *
+ * Side effects:
+ *	None
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+MaskEmpty(maskPtr)
+    long *maskPtr;
+{
+    long *runPtr, *tailPtr;
+    int found, sz;
+
+    sz = 3 * ((MASK_SIZE) / sizeof(long)) * sizeof(fd_mask);
+    for (runPtr = maskPtr, tailPtr = maskPtr + sz, found = 0;
+             runPtr < tailPtr;
+             runPtr++) {
+        if (*runPtr != 0) {
+            found = 1;
+            break;
+        }
+    }
+    return !found;    
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_WaitForEvent --
+ *
+ *	This procedure does the lowest level wait for events in a
+ *	platform-specific manner.  It uses information provided by
+ *	previous calls to Tcl_WatchFile, plus the timePtr argument,
+ *	to determine what to wait for and how long to wait.
+ *
+ * Results:
+ *	The return value is normally TCL_OK.  However, if there are
+ *	no events to wait for (e.g. no files and no timers) so that
+ *	the procedure would block forever, then it returns TCL_ERROR.
+ *
+ * Side effects:
+ *	May put the process to sleep for a while, depending on timePtr.
+ *	When this procedure returns, an event of interest to the application
+ *	has probably, but not necessarily, occurred.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_WaitForEvent(timePtr)
+    Tcl_Time *timePtr;		/* Specifies the maximum amount of time
+				 * that this procedure should block before
+				 * returning.  The time is given as an
+				 * interval, not an absolute wakeup time.
+				 * NULL means block forever. */
+{
+    struct timeval timeout, *timeoutPtr;
+    int numFound;
+
+    memcpy((VOID *) readyMasks, (VOID *) checkMasks,
+	    3*MASK_SIZE*sizeof(fd_mask));
+    if (timePtr == NULL) {
+	if ((numFdBits == 0) || (MaskEmpty((long *) readyMasks))) {
+	    return TCL_ERROR;
+	}
+	timeoutPtr = NULL;
+    } else {
+	timeoutPtr = &timeout;
+	timeout.tv_sec = timePtr->sec;
+	timeout.tv_usec = timePtr->usec;
+    }
+    numFound = select(numFdBits, (SELECT_MASK *) &readyMasks[0],
+	    (SELECT_MASK *) &readyMasks[MASK_SIZE],
+	    (SELECT_MASK *) &readyMasks[2*MASK_SIZE], timeoutPtr);
+
+    /*
+     * Some systems don't clear the masks after an error, so
+     * we have to do it here.
+     */
+
+    if (numFound == -1) {
+	memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask));
+    }
+
+    /*
+     * Reset the check masks in preparation for the next call to
+     * select.
+     */
+
+    numFdBits = 0;
+    memset((VOID *) checkMasks, 0, 3*MASK_SIZE*sizeof(fd_mask));
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Sleep --
+ *
+ *	Delay execution for the specified number of milliseconds.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Time passes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_Sleep(ms)
+    int ms;			/* Number of milliseconds to sleep. */
+{
+    static struct timeval delay;
+    Tcl_Time before, after;
+
+    /*
+     * The only trick here is that select appears to return early
+     * under some conditions, so we have to check to make sure that
+     * the right amount of time really has elapsed.  If it's too
+     * early, go back to sleep again.
+     */
+
+    TclGetTime(&before);
+    after = before;
+    after.sec += ms/1000;
+    after.usec += (ms%1000)*1000;
+    if (after.usec > 1000000) {
+	after.usec -= 1000000;
+	after.sec += 1;
+    }
+    while (1) {
+	delay.tv_sec = after.sec - before.sec;
+	delay.tv_usec = after.usec - before.usec;
+	if (delay.tv_usec < 0) {
+	    delay.tv_usec += 1000000;
+	    delay.tv_sec -= 1;
+	}
+
+	/*
+	 * Special note:  must convert delay.tv_sec to int before comparing
+	 * to zero, since delay.tv_usec is unsigned on some platforms.
+	 */
+
+	if ((((int) delay.tv_sec) < 0)
+		|| ((delay.tv_usec == 0) && (delay.tv_sec == 0))) {
+	    break;
+	}
+	(void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0,
+		(SELECT_MASK *) 0, &delay);
+	TclGetTime(&before);
+    }
+}
+

cde/programs/dtdocbook/tcl/tclUnixPipe.c

@@ -0,0 +1,498 @@
+/* $XConsortium: tclUnixPipe.c /main/3 1996/10/03 17:18:23 drk $ */
+/* 
+ * tclUnixPipe.c -- This file implements the UNIX-specific exec pipeline 
+ *                  functions.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclUnixPipe.c 1.29 96/04/18 15:56:26
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * Declarations for local procedures defined in this file:
+ */
+
+static void             RestoreSignals _ANSI_ARGS_((void));
+static int		SetupStdFile _ANSI_ARGS_((Tcl_File file, int type));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RestoreSignals --
+ *
+ *      This procedure is invoked in a forked child process just before
+ *      exec-ing a new program to restore all signals to their default
+ *      settings.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      Signal settings get changed.
+ *
+ *----------------------------------------------------------------------
+ */
+ 
+static void
+RestoreSignals()
+{
+#ifdef SIGABRT
+    signal(SIGABRT, SIG_DFL);
+#endif
+#ifdef SIGALRM
+    signal(SIGALRM, SIG_DFL);
+#endif
+#ifdef SIGFPE
+    signal(SIGFPE, SIG_DFL);
+#endif
+#ifdef SIGHUP
+    signal(SIGHUP, SIG_DFL);
+#endif
+#ifdef SIGILL
+    signal(SIGILL, SIG_DFL);
+#endif
+#ifdef SIGINT
+    signal(SIGINT, SIG_DFL);
+#endif
+#ifdef SIGPIPE
+    signal(SIGPIPE, SIG_DFL);
+#endif
+#ifdef SIGQUIT
+    signal(SIGQUIT, SIG_DFL);
+#endif
+#ifdef SIGSEGV
+    signal(SIGSEGV, SIG_DFL);
+#endif
+#ifdef SIGTERM
+    signal(SIGTERM, SIG_DFL);
+#endif
+#ifdef SIGUSR1
+    signal(SIGUSR1, SIG_DFL);
+#endif
+#ifdef SIGUSR2
+    signal(SIGUSR2, SIG_DFL);
+#endif
+#ifdef SIGCHLD
+    signal(SIGCHLD, SIG_DFL);
+#endif
+#ifdef SIGCONT
+    signal(SIGCONT, SIG_DFL);
+#endif
+#ifdef SIGTSTP
+    signal(SIGTSTP, SIG_DFL);
+#endif
+#ifdef SIGTTIN
+    signal(SIGTTIN, SIG_DFL);
+#endif
+#ifdef SIGTTOU
+    signal(SIGTTOU, SIG_DFL);
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetupStdFile --
+ *
+ *	Set up stdio file handles for the child process, using the
+ *	current standard channels if no other files are specified.
+ *	If no standard channel is defined, or if no file is associated
+ *	with the channel, then the corresponding standard fd is closed.
+ *
+ * Results:
+ *	Returns 1 on success, or 0 on failure.
+ *
+ * Side effects:
+ *	Replaces stdio fds.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetupStdFile(file, type)
+    Tcl_File file;		/* File to dup, or NULL. */
+    int type;			/* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR */
+{
+    Tcl_Channel channel;
+    int fd;
+    int targetFd = 0;		/* Initializations here needed only to */
+    int direction = 0;		/* prevent warnings about using uninitialized
+				 * variables. */
+
+    switch (type) {
+	case TCL_STDIN:
+	    targetFd = 0;
+	    direction = TCL_READABLE;
+	    break;
+	case TCL_STDOUT:
+	    targetFd = 1;
+	    direction = TCL_WRITABLE;
+	    break;
+	case TCL_STDERR:
+	    targetFd = 2;
+	    direction = TCL_WRITABLE;
+	    break;
+    }
+
+    if (!file) {
+	channel = Tcl_GetStdChannel(type);
+	if (channel) {
+	    file = Tcl_GetChannelFile(channel, direction);
+	}
+    }
+    if (file) {
+	fd = (int)Tcl_GetFileInfo(file, NULL);
+	if (fd != targetFd) {
+	    if (dup2(fd, targetFd) == -1) {
+		return 0;
+	    }
+
+            /*
+             * Must clear the close-on-exec flag for the target FD, since
+             * some systems (e.g. Ultrix) do not clear the CLOEXEC flag on
+             * the target FD.
+             */
+            
+            fcntl(targetFd, F_SETFD, 0);
+	} else {
+	    int result;
+
+	    /*
+	     * Since we aren't dup'ing the file, we need to explicitly clear
+	     * the close-on-exec flag.
+	     */
+
+	    result = fcntl(fd, F_SETFD, 0);
+	}
+    } else {
+	close(targetFd);
+    }
+    return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSpawnPipeline --
+ *
+ *      Given an argc/argv array, instantiate a pipeline of processes
+ *      as described by the argv.
+ *
+ * Results:
+ *      The return value is 1 on success, 0 on error
+ *
+ * Side effects:
+ *      Processes and pipes are created.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclSpawnPipeline(interp, pidPtr, numPids, argc, argv, inputFile,
+	outputFile, errorFile, intIn, finalOut)
+    Tcl_Interp *interp;		/* Interpreter in which to process pipeline. */
+    pid_t *pidPtr;		/* Array of pids which are created. */
+    int *numPids;		/* Number of pids created. */
+    int argc;			/* Number of entries in argv. */
+    char **argv;		/* Array of strings describing commands in
+				 * pipeline plus I/O redirection with <,
+				 * <<, >, etc. argv[argc] must be NULL. */
+    Tcl_File inputFile;	/* If >=0, gives file id to use as input for
+				 * first process in pipeline (specified via <
+				 * or <@). */
+    Tcl_File outputFile;	/* Writable file id for output from last
+				 * command in pipeline (could be file or
+				 * pipe). NULL means use stdout. */
+    Tcl_File errorFile;	/* Writable file id for error output from all
+				 * commands in the pipeline. NULL means use
+				 * stderr */
+    char *intIn;		/* File name for initial input (for Win32s). */
+    char *finalOut;		/* File name for final output (for Win32s). */
+{
+    int firstArg, lastArg;
+    pid_t pid;
+    int count;
+    Tcl_DString buffer;
+    char *execName;
+    char errSpace[200];
+    Tcl_File pipeIn, errPipeIn, errPipeOut;
+    int joinThisError;
+    Tcl_File curOutFile = NULL, curInFile;
+    
+    Tcl_DStringInit(&buffer);
+    pipeIn = errPipeIn = errPipeOut = NULL;
+
+    curInFile = inputFile;
+
+    for (firstArg = 0; firstArg < argc; firstArg = lastArg+1) {
+
+	/*
+	 * Convert the program name into native form.
+	 */
+
+	Tcl_DStringFree(&buffer);
+	execName = Tcl_TranslateFileName(interp, argv[firstArg], &buffer);
+	if (execName == NULL) {
+	    goto error;
+	}
+
+	/*
+	 * Find the end of the current segment of the pipeline.
+	 */
+
+	joinThisError = 0;
+	for (lastArg = firstArg; lastArg < argc; lastArg++) {
+	    if (argv[lastArg][0] == '|') {
+		if (argv[lastArg][1] == 0) {
+		    break;
+		}
+		if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == 0)) {
+		    joinThisError = 1;
+		    break;
+		}
+	    }
+	}
+	argv[lastArg] = NULL;
+
+	/*
+	 * If this is the last segment, use the specified outputFile.
+	 * Otherwise create an intermediate pipe.
+	 */
+
+	if (lastArg == argc) {
+	    curOutFile = outputFile;
+	} else {
+	    if (TclCreatePipe(&pipeIn, &curOutFile) == 0) {
+		Tcl_AppendResult(interp, "couldn't create pipe: ",
+			Tcl_PosixError(interp), (char *) NULL);
+		goto error;
+	    }
+	}
+
+	/*
+	 * Create a pipe that the child can use to return error
+	 * information if anything goes wrong.
+	 */
+
+	if (TclCreatePipe(&errPipeIn, &errPipeOut) == 0) {
+	    Tcl_AppendResult(interp, "couldn't create pipe: ",
+		    Tcl_PosixError(interp), (char *) NULL);
+	    goto error;
+	}
+
+	pid = vfork();
+	if (pid == 0) {
+
+	    /*
+	     * Set up stdio file handles for the child process.
+	     */
+
+	    if (!SetupStdFile(curInFile, TCL_STDIN)
+		    || !SetupStdFile(curOutFile, TCL_STDOUT)
+		    || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR))
+		    || (joinThisError &&
+                            ((dup2(1,2) == -1) ||
+                             (fcntl(2, F_SETFD, 0) != 0)))) {
+		sprintf(errSpace,
+			"%dforked process couldn't set up input/output: ",
+			errno);
+		TclWriteFile(errPipeOut, 1, errSpace, (int) strlen(errSpace));
+		_exit(1);
+	    }
+
+            /*
+             * Close the input side of the error pipe.
+             */
+
+	    RestoreSignals();
+	    execvp(execName, &argv[firstArg]);
+	    sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno,
+		    argv[firstArg]);
+	    TclWriteFile(errPipeOut, 1, errSpace, (int) strlen(errSpace));
+	    _exit(1);
+	}
+	Tcl_DStringFree(&buffer);
+	if (pid == (pid_t)-1) {
+	    Tcl_AppendResult(interp, "couldn't fork child process: ",
+		    Tcl_PosixError(interp), (char *) NULL);
+	    goto error;
+	}
+
+	/*
+	 * Add the child process to the list of those to be reaped.
+	 * Note: must do it now, so that the process will be reaped even if
+	 * an error occurs during its startup.
+	 */
+	
+	pidPtr[*numPids] = pid;
+	(*numPids)++;
+	
+	/*
+	 * Read back from the error pipe to see if the child startup
+	 * up OK.  The info in the pipe (if any) consists of a decimal
+	 * errno value followed by an error message.
+	 */
+
+	TclCloseFile(errPipeOut);
+	errPipeOut = NULL;
+
+	count = TclReadFile(errPipeIn, 1, errSpace,
+		(size_t) (sizeof(errSpace) - 1));
+	if (count > 0) {
+	    char *end;
+	    errSpace[count] = 0;
+	    errno = strtol(errSpace, &end, 10);
+	    Tcl_AppendResult(interp, end, Tcl_PosixError(interp),
+		    (char *) NULL);
+	    goto error;
+	}
+	TclCloseFile(errPipeIn);
+	errPipeIn = NULL;
+
+	/*
+	 * Close off our copies of file descriptors that were set up for
+	 * this child, then set up the input for the next child.
+	 */
+
+	if (curInFile && (curInFile != inputFile)) {
+	    TclCloseFile(curInFile);
+	}
+	curInFile = pipeIn;
+	pipeIn = NULL;
+
+	if (curOutFile && (curOutFile != outputFile)) {
+	    TclCloseFile(curOutFile);
+	}
+	curOutFile = NULL;
+    }
+    return 1;
+
+    /*
+     * An error occured, so we need to clean up any open pipes.
+     */
+
+error:
+    Tcl_DStringFree(&buffer);
+    if (errPipeIn) {
+	TclCloseFile(errPipeIn);
+    }
+    if (errPipeOut) {
+	TclCloseFile(errPipeOut);
+    }
+    if (pipeIn) {
+	TclCloseFile(pipeIn);
+    }
+    if (curOutFile && (curOutFile != outputFile)) {
+	TclCloseFile(curOutFile);
+    }
+    if (curInFile && (curInFile != inputFile)) {
+	TclCloseFile(curInFile);
+    }
+    return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCreatePipe --
+ *
+ *      Creates a pipe - simply calls the pipe() function.
+ *
+ * Results:
+ *      Returns 1 on success, 0 on failure. 
+ *
+ * Side effects:
+ *      Creates a pipe.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclCreatePipe(readPipe, writePipe)
+    Tcl_File *readPipe;	/* Location to store file handle for
+				 * read side of pipe. */
+    Tcl_File *writePipe;	/* Location to store file handle for
+				 * write side of pipe. */
+{
+    int pipeIds[2];
+
+    if (pipe(pipeIds) != 0) {
+	return 0;
+    }
+
+    fcntl(pipeIds[0], F_SETFD, FD_CLOEXEC);
+    fcntl(pipeIds[1], F_SETFD, FD_CLOEXEC);
+
+    *readPipe = Tcl_GetFile((ClientData)pipeIds[0], TCL_UNIX_FD);
+    *writePipe = Tcl_GetFile((ClientData)pipeIds[1], TCL_UNIX_FD);
+    return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreatePipeline --
+ *
+ *	This function is a compatibility wrapper for TclCreatePipeline.
+ *	It is only available under Unix, and may be removed from later
+ *	versions.
+ *
+ * Results:
+ *	Same as TclCreatePipeline.
+ *
+ * Side effects:
+ *	Same as TclCreatePipeline.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_CreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr,
+	outPipePtr, errFilePtr)
+    Tcl_Interp *interp;
+    int argc;
+    char **argv;
+    pid_t **pidArrayPtr;
+    int *inPipePtr;
+    int *outPipePtr;
+    int *errFilePtr;
+{
+    Tcl_File inFile, outFile, errFile;
+    int result;
+
+    result = TclCreatePipeline(interp, argc, argv, pidArrayPtr,
+	    (inPipePtr ? &inFile : NULL),
+	    (outPipePtr ? &outFile : NULL),
+	    (errFilePtr ? &errFile : NULL));
+
+    if (inPipePtr) {
+	if (inFile) {
+	    *inPipePtr = (int) Tcl_GetFileInfo(inFile, NULL);
+	    Tcl_FreeFile(inFile);
+	} else {
+	    *inPipePtr = -1;
+	}
+    }
+    if (outPipePtr) {
+	if (outFile) {
+	    *outPipePtr = (int) Tcl_GetFileInfo(outFile, NULL);
+	    Tcl_FreeFile(outFile);
+	} else {
+	    *outPipePtr = -1;
+	}
+    }
+    if (errFilePtr) {
+	if (errFile) {
+	    *errFilePtr = (int) Tcl_GetFileInfo(errFile, NULL);
+	    Tcl_FreeFile(errFile);
+	} else {
+	    *errFilePtr = -1;
+	}
+    }
+    return result;
+}

cde/programs/dtdocbook/tcl/tclUnixPort.h

@@ -0,0 +1,414 @@
+/* $XConsortium: tclUnixPort.h /main/2 1996/08/08 14:46:57 cde-hp $ */
+/*
+ * tclUnixPort.h --
+ *
+ *	This header file handles porting issues that occur because
+ *	of differences between systems.  It reads in UNIX-related
+ *	header files and sets up UNIX-related macros for Tcl's UNIX
+ *	core.  It should be the only file that contains #ifdefs to
+ *	handle different flavors of UNIX.  This file sets up the
+ *	union of all UNIX-related things needed by any of the Tcl
+ *	core files.  This file depends on configuration #defines such
+ *	as NO_DIRENT_H that are set up by the "configure" script.
+ *
+ *	Much of the material in this file was originally contributed
+ *	by Karl Lehenbauer, Mark Diekhans and Peter da Silva.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclUnixPort.h 1.33 96/03/25 17:15:21
+ */
+
+#ifndef _TCLUNIXPORT
+#define _TCLUNIXPORT
+
+#ifndef _TCLINT
+#   include "tclInt.h"
+#endif
+#include <errno.h>
+#include <fcntl.h>
+#ifdef HAVE_NET_ERRNO_H
+#   include <net/errno.h>
+#endif
+#include <pwd.h>
+#include <signal.h>
+#include <sys/param.h>
+#include <sys/types.h>
+#ifdef USE_DIRENT2_H
+#   include "../compat/dirent2.h"
+#else
+#   ifdef NO_DIRENT_H
+#	include "../compat/dirent.h"
+#   else
+#	include <dirent.h>
+#   endif
+#endif
+#include <sys/file.h>
+#ifdef HAVE_SYS_SELECT_H
+#   include <sys/select.h>
+#endif
+#include <sys/stat.h>
+#if TIME_WITH_SYS_TIME
+#   include <sys/time.h>
+#   include <time.h>
+#else
+#   if HAVE_SYS_TIME_H
+#       include <sys/time.h>
+#   else
+#       include <time.h>
+#   endif
+#endif
+#ifndef NO_SYS_WAIT_H
+#   include <sys/wait.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#   include <unistd.h>
+#else
+#   include "../compat/unistd.h"
+#endif
+
+/*
+ * Socket support stuff: This likely needs more work to parameterize for
+ * each system.
+ */
+
+#include <sys/socket.h>		/* struct sockaddr, SOCK_STREAM, ... */
+#include <sys/utsname.h>	/* uname system call. */
+#include <netinet/in.h>		/* struct in_addr, struct sockaddr_in */
+#include <arpa/inet.h>		/* inet_ntoa() */
+#include <netdb.h>		/* gethostbyname() */
+
+/*
+ * NeXT doesn't define O_NONBLOCK, so #define it here if necessary.
+ */
+
+#ifndef O_NONBLOCK
+#   define O_NONBLOCK 0x80
+#endif
+
+/*
+ * HPUX needs the flag O_NONBLOCK to get the right non-blocking I/O
+ * semantics, while most other systems need O_NDELAY.  Define the
+ * constant NBIO_FLAG to be one of these
+ */
+
+#ifdef HPUX
+#  define NBIO_FLAG O_NONBLOCK
+#else
+#  define NBIO_FLAG O_NDELAY
+#endif
+
+/*
+ * The default platform eol translation on Unix is TCL_TRANSLATE_LF:
+ */
+
+#define	TCL_PLATFORM_TRANSLATION	TCL_TRANSLATE_LF
+
+/*
+ * Not all systems declare the errno variable in errno.h. so this
+ * file does it explicitly.  The list of system error messages also
+ * isn't generally declared in a header file anywhere.
+ */
+
+extern int errno;
+
+/*
+ * The type of the status returned by wait varies from UNIX system
+ * to UNIX system.  The macro below defines it:
+ */
+
+#ifdef _AIX
+#   define WAIT_STATUS_TYPE pid_t
+#else
+#ifndef NO_UNION_WAIT
+#   define WAIT_STATUS_TYPE union wait
+#else
+#   define WAIT_STATUS_TYPE int
+#endif
+#endif
+
+/*
+ * Supply definitions for macros to query wait status, if not already
+ * defined in header files above.
+ */
+
+#ifndef WIFEXITED
+#   define WIFEXITED(stat)  (((*((int *) &(stat))) & 0xff) == 0)
+#endif
+
+#ifndef WEXITSTATUS
+#   define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff)
+#endif
+
+#ifndef WIFSIGNALED
+#   define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff)))
+#endif
+
+#ifndef WTERMSIG
+#   define WTERMSIG(stat)    ((*((int *) &(stat))) & 0x7f)
+#endif
+
+#ifndef WIFSTOPPED
+#   define WIFSTOPPED(stat)  (((*((int *) &(stat))) & 0xff) == 0177)
+#endif
+
+#ifndef WSTOPSIG
+#   define WSTOPSIG(stat)    (((*((int *) &(stat))) >> 8) & 0xff)
+#endif
+
+/*
+ * Define constants for waitpid() system call if they aren't defined
+ * by a system header file.
+ */
+
+#ifndef WNOHANG
+#   define WNOHANG 1
+#endif
+#ifndef WUNTRACED
+#   define WUNTRACED 2
+#endif
+
+/*
+ * Supply macros for seek offsets, if they're not already provided by
+ * an include file.
+ */
+
+#ifndef SEEK_SET
+#   define SEEK_SET 0
+#endif
+
+#ifndef SEEK_CUR
+#   define SEEK_CUR 1
+#endif
+
+#ifndef SEEK_END
+#   define SEEK_END 2
+#endif
+
+/*
+ * The stuff below is needed by the "time" command.  If this
+ * system has no gettimeofday call, then must use times and the
+ * CLK_TCK #define (from sys/param.h) to compute elapsed time.
+ * Unfortunately, some systems only have HZ and no CLK_TCK, and
+ * some might not even have HZ.
+ */
+
+#ifdef NO_GETTOD
+#   include <sys/times.h>
+#   include <sys/param.h>
+#   ifndef CLK_TCK
+#       ifdef HZ
+#           define CLK_TCK HZ
+#       else
+#           define CLK_TCK 60
+#       endif
+#   endif
+#else
+#   ifdef HAVE_BSDGETTIMEOFDAY
+#	define gettimeofday BSDgettimeofday
+#   endif
+#endif
+
+#ifdef GETTOD_NOT_DECLARED
+EXTERN int		gettimeofday _ANSI_ARGS_((struct timeval *tp,
+			    struct timezone *tzp));
+#endif
+
+/*
+ * Define access mode constants if they aren't already defined.
+ */
+
+#ifndef F_OK
+#    define F_OK 00
+#endif
+#ifndef X_OK
+#    define X_OK 01
+#endif
+#ifndef W_OK
+#    define W_OK 02
+#endif
+#ifndef R_OK
+#    define R_OK 04
+#endif
+
+/*
+ * Define FD_CLOEEXEC (the close-on-exec flag bit) if it isn't
+ * already defined.
+ */
+
+#ifndef FD_CLOEXEC
+#   define FD_CLOEXEC 1
+#endif
+
+/*
+ * On systems without symbolic links (i.e. S_IFLNK isn't defined)
+ * define "lstat" to use "stat" instead.
+ */
+
+#ifndef S_IFLNK
+#   define lstat stat
+#endif
+
+/*
+ * Define macros to query file type bits, if they're not already
+ * defined.
+ */
+
+#ifndef S_ISREG
+#   ifdef S_IFREG
+#       define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
+#   else
+#       define S_ISREG(m) 0
+#   endif
+# endif
+#ifndef S_ISDIR
+#   ifdef S_IFDIR
+#       define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR)
+#   else
+#       define S_ISDIR(m) 0
+#   endif
+# endif
+#ifndef S_ISCHR
+#   ifdef S_IFCHR
+#       define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR)
+#   else
+#       define S_ISCHR(m) 0
+#   endif
+# endif
+#ifndef S_ISBLK
+#   ifdef S_IFBLK
+#       define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK)
+#   else
+#       define S_ISBLK(m) 0
+#   endif
+# endif
+#ifndef S_ISFIFO
+#   ifdef S_IFIFO
+#       define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
+#   else
+#       define S_ISFIFO(m) 0
+#   endif
+# endif
+#ifndef S_ISLNK
+#   ifdef S_IFLNK
+#       define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
+#   else
+#       define S_ISLNK(m) 0
+#   endif
+# endif
+#ifndef S_ISSOCK
+#   ifdef S_IFSOCK
+#       define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK)
+#   else
+#       define S_ISSOCK(m) 0
+#   endif
+# endif
+
+/*
+ * Make sure that MAXPATHLEN is defined.
+ */
+
+#ifndef MAXPATHLEN
+#   ifdef PATH_MAX
+#       define MAXPATHLEN PATH_MAX
+#   else
+#       define MAXPATHLEN 2048
+#   endif
+#endif
+
+/*
+ * Make sure that L_tmpnam is defined.
+ */
+
+#ifndef L_tmpnam
+#   define L_tmpnam 100
+#endif
+
+/*
+ * The following macro defines the type of the mask arguments to
+ * select:
+ */
+
+#ifndef NO_FD_SET
+#   define SELECT_MASK fd_set
+#else
+#   ifndef _AIX
+	typedef long fd_mask;
+#   endif
+#   if defined(_IBMR2)
+#	define SELECT_MASK void
+#   else
+#	define SELECT_MASK int
+#   endif
+#endif
+
+/*
+ * Define "NBBY" (number of bits per byte) if it's not already defined.
+ */
+
+#ifndef NBBY
+#   define NBBY 8
+#endif
+
+/*
+ * The following macro defines the number of fd_masks in an fd_set:
+ */
+
+#ifndef FD_SETSIZE
+#   ifdef OPEN_MAX
+#	define FD_SETSIZE OPEN_MAX
+#   else
+#	define FD_SETSIZE 256
+#   endif
+#endif
+#if !defined(howmany)
+#   define howmany(x, y) (((x)+((y)-1))/(y))
+#endif
+#ifndef NFDBITS
+#   define NFDBITS NBBY*sizeof(fd_mask)
+#endif
+#define MASK_SIZE howmany(FD_SETSIZE, NFDBITS)
+
+/*
+ * The following function is declared in tclInt.h but doesn't do anything
+ * on Unix systems.
+ */
+
+#define TclSetSystemEnv(a,b)
+
+/*
+ * The following implements the Unix method for exiting the process.
+ */
+#define TclPlatformExit(status) exit(status)
+
+/*
+ * The following functions always succeeds under Unix.
+ */
+
+#define TclHasSockets(interp) (TCL_OK)
+#define TclHasPipes() (1)
+
+/*
+ * Variables provided by the C library:
+ */
+
+#if defined(_sgi) || defined(__sgi)
+#define environ _environ
+#endif
+extern char **environ;
+
+/*
+ * At present (12/91) not all stdlib.h implementations declare strtod.
+ * The declaration below is here to ensure that it's declared, so that
+ * the compiler won't take the default approach of assuming it returns
+ * an int.  There's no ANSI prototype for it because there would end
+ * up being too many conflicts with slightly-different prototypes.
+ */
+
+extern double strtod();
+
+#endif /* _TCLUNIXPORT */

cde/programs/dtdocbook/tcl/tclUnixSock.c

@@ -0,0 +1,66 @@
+/* $XConsortium: tclUnixSock.c /main/2 1996/08/08 14:47:01 cde-hp $ */
+/* 
+ * tclUnixSock.c --
+ *
+ *	This file contains Unix-specific socket related code.
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclUnixSock.c 1.5 96/04/04 15:28:39
+ */
+
+#include "tcl.h"
+#include "tclPort.h"
+
+/*
+ * The following variable holds the network name of this host.
+ */
+
+#ifndef SYS_NMLN
+#   define SYS_NMLN 100
+#endif
+
+static char hostname[SYS_NMLN + 1];
+static int  hostnameInited = 0;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetHostName --
+ *
+ *	Get the network name for this machine, in a system dependent way.
+ *
+ * Results:
+ *	A string containing the network name for this machine.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_GetHostName()
+{
+    struct utsname u;
+    struct hostent *hp;
+
+    if (hostnameInited) {
+        return hostname;
+    }
+    
+    if (uname(&u) > -1) {
+        hp = gethostbyname(u.nodename);
+        if (hp != NULL) {
+            strcpy(hostname, hp->h_name);
+        } else {
+            strcpy(hostname, u.nodename);
+        }
+        hostnameInited = 1;
+        return hostname;
+    }
+    return (char *) NULL;
+}

cde/programs/dtdocbook/tcl/tclUnixTime.c

@@ -0,0 +1,219 @@
+/* $TOG: tclUnixTime.c /main/3 1998/04/06 13:37:56 mgreess $ */
+/* 
+ * tclUnixTime.c --
+ *
+ *	Contains Unix specific versions of Tcl functions that
+ *	obtain time values from the operating system.
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclUnixTime.c 1.10 96/02/15 11:58:41
+ */
+
+#include <sys/time.h>
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclGetSeconds --
+ *
+ *	This procedure returns the number of seconds from the epoch.  On
+ *	most Unix systems the epoch is Midnight Jan 1, 1970 GMT.
+ *
+ * Results:
+ *	Number of seconds from the epoch.
+ *
+ * Side effects:
+ *	None.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+unsigned long
+TclGetSeconds()
+{
+    return time((time_t *) NULL);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclGetClicks --
+ *
+ *	This procedure returns a value that represents the highest resolution
+ *	clock available on the system.  There are no garantees on what the
+ *	resolution will be.  In Tcl we will call this value a "click".  The
+ *	start time is also system dependant.
+ *
+ * Results:
+ *	Number of clicks from some start time.
+ *
+ * Side effects:
+ *	None.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+unsigned long
+TclGetClicks()
+{
+    unsigned long now;
+#ifdef NO_GETTOD
+    struct tms dummy;
+#else
+    struct timeval date;
+    struct timezone tz;
+#endif
+
+#ifdef NO_GETTOD
+    now = (unsigned long) times(&dummy);
+#else
+    gettimeofday(&date, &tz);
+    now = date.tv_sec*1000000 + date.tv_usec;
+#endif
+
+    return now;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetTimeZone --
+ *
+ *	Determines the current timezone.  The method varies wildly
+ *	between different platform implementations, so its hidden in
+ *	this function.
+ *
+ * Results:
+ *	Hours east of GMT.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGetTimeZone (currentTime)
+    unsigned long  currentTime;
+{
+    /*
+     * Determine how a timezone is obtained from "struct tm".  If there is no
+     * time zone in this struct (very lame) then use the timezone variable.
+     * This is done in a way to make the timezone variable the method of last
+     * resort, as some systems have it in addition to a field in "struct tm".
+     * The gettimeofday system call can also be used to determine the time
+     * zone.
+     */
+    
+#if defined(HAVE_TM_TZADJ)
+#   define TCL_GOT_TIMEZONE
+    time_t      curTime = (time_t) currentTime;
+    struct tm  *timeDataPtr = localtime(&curTime);
+    int         timeZone;
+
+    timeZone = timeDataPtr->tm_tzadj  / 60;
+    if (timeDataPtr->tm_isdst) {
+        timeZone += 60;
+    }
+    
+    return timeZone;
+#endif
+
+#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE)
+#   define TCL_GOT_TIMEZONE
+    time_t     curTime = (time_t) currentTime;
+    struct tm *timeDataPtr = localtime(&currentTime);
+    int        timeZone;
+
+    timeZone = -(timeDataPtr->tm_gmtoff / 60);
+    if (timeDataPtr->tm_isdst) {
+        timeZone += 60;
+    }
+    
+    return timeZone;
+#endif
+
+    /*
+     * Must prefer timezone variable over gettimeofday, as gettimeofday does
+     * not return timezone information on many systems that have moved this
+     * information outside of the kernel.
+     */
+    
+#if defined(HAVE_TIMEZONE_VAR) && !defined (TCL_GOT_TIMEZONE)
+#   define TCL_GOT_TIMEZONE
+    static int setTZ = 0;
+    int        timeZone;
+
+    if (!setTZ) {
+        tzset();
+        setTZ = 1;
+    }
+
+    /*
+     * Note: this is not a typo in "timezone" below!  See tzset
+     * documentation for details.
+     */
+
+    timeZone = timezone / 60;
+
+    return timeZone;
+#endif
+
+#if defined(HAVE_GETTIMEOFDAY) && !defined (TCL_GOT_TIMEZONE)
+#   define TCL_GOT_TIMEZONE
+    struct timeval  tv;
+    struct timezone tz;
+    int timeZone;
+
+    gettimeofday(&tv, &tz);
+    timeZone = tz.tz_minuteswest;
+    if (tz.tz_dsttime) {
+        timeZone += 60;
+    }
+    
+    return timeZone;
+#endif
+
+#ifndef TCL_GOT_TIMEZONE
+    /*
+     * Cause compile error, we don't know how to get timezone.
+     */
+    error: autoconf did not figure out how to determine the timezone. 
+#endif
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetTime --
+ *
+ *	Gets the current system time in seconds and microseconds
+ *	since the beginning of the epoch: 00:00 UCT, January 1, 1970.
+ *
+ * Results:
+ *	Returns the current time in timePtr.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclGetTime(timePtr)
+    Tcl_Time *timePtr;		/* Location to store time information. */
+{
+    struct timeval tv;
+    struct timezone tz;
+    
+    (void) gettimeofday(&tv, &tz);
+    timePtr->sec = tv.tv_sec;
+    timePtr->usec = tv.tv_usec;
+}