external/cde
1
0
Fork 0
mirror of git://git.code.sf.net/p/cdesktopenv/code synced 2025-03-09 15:50:02 +00:00
Code Issues Releases Wiki Activity

Remove ancient included tcl code

Browse source
This commit is contained in:
Jon Trulson 2018-09-22 12:27:09 -06:00
parent 1c40db8eb0
commit 1fb82e3327
51 changed files with 0 additions and 49909 deletions
Download patch file Download diff file Expand all files Collapse all files

95
cde/programs/dtdocbook/tcl/Imakefile
View file

@ -1,95 +0,0 @@
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 = 8.5
#if defined(LinuxArchitecture)
prefix = /usr/lib
#elif defined(OpenBSDArchitecture)
prefix = /usr/local/lib/tcl
#elif defined(NetBSDArchitecture)
prefix = /usr/pkg/lib
#else
prefix = /usr/local/lib
#endif
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):
#ifdef TclLibrary
TCL_LIBRARY = TclLibrary
#else
TCL_LIBRARY = $(prefix)/tcl$(VERSION)
#endif
DEPEND_DEFINES = $(DEPENDDEFINES)
#if defined(SunArchitecture)
EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
-DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR \
-DTCL_GOT_TIMEZONE
#elif defined(IBMArchitecture)
EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
-DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR -Dvfork=fork \
-DTCL_GOT_TIMEZONE -DHAVE_SYS_SELECT_H
#elif defined(AlphaArchitecture)
EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
-DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR \
-DTCL_GOT_TIMEZONE -DTIME_WITH_SYS_TIME
#elif defined(OpenBSDArchitecture)
EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
-DNO_UNION_WAIT -DHAVE_UNISTD_H \
-DTCL_GOT_TIMEZONE
#elif defined(FreeBSDArchitecture)
EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
-DNO_UNION_WAIT -DHAVE_UNISTD_H \
-DTCL_GOT_TIMEZONE
#elif defined(NetBSDArchitecture)
EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
-DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR \
-DTCL_GOT_TIMEZONE
#else
EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
-DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR \
-DTCL_GOT_TIMEZONE
#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()

32
cde/programs/dtdocbook/tcl/license.terms
View file

@ -1,32 +0,0 @@
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.

111
cde/programs/dtdocbook/tcl/panic.c
View file

@ -1,111 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(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(char *format /* Format string, suitable for passing to fprintf. */,
char *arg1, char *arg2, char *arg3 /* Additional arguments (variable in number) to pass to fprintf. */,
char *arg4, char *arg5, char *arg6, char *arg7, char *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();
}
}

46
cde/programs/dtdocbook/tcl/patchlevel.h
View file

@ -1,46 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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"

1321
cde/programs/dtdocbook/tcl/regexp.c
View file

File diff suppressed because it is too large Load diff

1087
cde/programs/dtdocbook/tcl/tcl.h
View file

File diff suppressed because it is too large Load diff

281
cde/programs/dtdocbook/tcl/tclAsync.c
View file

@ -1,281 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(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(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.
*
*----------------------------------------------------------------------
*/
/* interp, If invoked from Tcl_Eval just after completing a command,
* points to interpreter. Otherwise it is NULL. */
/* code, If interp is non-NULL, this gives completion code from command
* that just completed. */
int
Tcl_AsyncInvoke(Tcl_Interp *interp, int code)
{
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(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(void)
{
return asyncReady;
}

1864
cde/programs/dtdocbook/tcl/tclBasic.c
View file

File diff suppressed because it is too large Load diff

745
cde/programs/dtdocbook/tcl/tclCkalloc.c
View file

@ -1,745 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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 (unsigned int size)
{
char *result;
result = malloc(size);
if (result == NULL)
panic("unable to alloc %d bytes", size);
return result;
}
char *
Tcl_DbCkalloc(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(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 (char *ptr)
{
free (ptr);
}
int
Tcl_DbCkfree(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(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 (char *fileName)
{
return TCL_OK;
}
void
Tcl_ValidateAllMemory (char *file, int line)
{
}
#endif

375
cde/programs/dtdocbook/tcl/tclClock.c
View file

@ -1,375 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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 (
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(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(
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;
}

1715
cde/programs/dtdocbook/tcl/tclCmdAH.c
View file

File diff suppressed because it is too large Load diff

1521
cde/programs/dtdocbook/tcl/tclCmdIL.c
View file

File diff suppressed because it is too large Load diff

2145
cde/programs/dtdocbook/tcl/tclCmdMZ.c
View file

File diff suppressed because it is too large Load diff

1617
cde/programs/dtdocbook/tcl/tclDate.c
View file

File diff suppressed because it is too large Load diff

635
cde/programs/dtdocbook/tcl/tclEnv.c
View file

@ -1,635 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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(
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;
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(
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(
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(
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(
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 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) {
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(void)
{
#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 /* Not used. */
)
{
char **p;
for (p = environ; *p != NULL; p++) {
ckfree(*p);
}
ckfree((char *) environ);
}

2241
cde/programs/dtdocbook/tcl/tclEvent.c
View file

File diff suppressed because it is too large Load diff

2105
cde/programs/dtdocbook/tcl/tclExpr.c
View file

File diff suppressed because it is too large Load diff

283
cde/programs/dtdocbook/tcl/tclFHandle.c
View file

@ -1,283 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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(
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(
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(
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(
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 /* 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);
}

1628
cde/programs/dtdocbook/tcl/tclFileName.c
View file

File diff suppressed because it is too large Load diff

258
cde/programs/dtdocbook/tcl/tclGet.c
View file

@ -1,258 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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(
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(
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;
}

960
cde/programs/dtdocbook/tcl/tclHash.c
View file

@ -1,960 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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(
Tcl_HashEntry *entryPtr
)
{
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(
Tcl_HashTable *tablePtr /* Table to delete. */
)
{
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(
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(
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(
Tcl_HashTable *tablePtr /* Table for which to produce stats. */
)
{
#define NUM_COUNTERS 10
int count[NUM_COUNTERS], overflow, i, j;
double average, tmp;
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(
char *string /* String from which to compute hash value. */
)
{
unsigned int result;
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(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
char *key /* Key to use to find matching entry. */
)
{
Tcl_HashEntry *hPtr;
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(
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. */
)
{
Tcl_HashEntry *hPtr;
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(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
char *key /* Key to use to find matching entry. */
)
{
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(
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. */
)
{
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(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
char *key /* Key to use to find matching entry. */
)
{
Tcl_HashEntry *hPtr;
int *arrayPtr = (int *) key;
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(
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. */
)
{
Tcl_HashEntry *hPtr;
int *arrayPtr = (int *) key;
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(
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(
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(
Tcl_HashTable *tablePtr /* Table to enlarge. */
)
{
int oldSize, count, index;
Tcl_HashEntry **oldBuckets;
Tcl_HashEntry **oldChainPtr, **newChainPtr;
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 {
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);
}
}

1130
cde/programs/dtdocbook/tcl/tclHistory.c
View file

File diff suppressed because it is too large Load diff

5130
cde/programs/dtdocbook/tcl/tclIO.c
View file

File diff suppressed because it is too large Load diff

1552
cde/programs/dtdocbook/tcl/tclIOCmd.c
View file

File diff suppressed because it is too large Load diff

121
cde/programs/dtdocbook/tcl/tclIOSock.c
View file

@ -1,121 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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(
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;
}

1320
cde/programs/dtdocbook/tcl/tclIOUtil.c
View file

File diff suppressed because it is too large Load diff

1101
cde/programs/dtdocbook/tcl/tclInt.h
View file

File diff suppressed because it is too large Load diff

2434
cde/programs/dtdocbook/tcl/tclInterp.c
View file

File diff suppressed because it is too large Load diff

418
cde/programs/dtdocbook/tcl/tclLink.c
View file

@ -1,418 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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(
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(
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 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 variable'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(
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 "??";
}

628
cde/programs/dtdocbook/tcl/tclLoad.c
View file

@ -1,628 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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(
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(
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 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 /* Not used. */
)
{
LoadedPackage *pkgPtr;
while (firstPackagePtr != NULL) {
pkgPtr = firstPackagePtr;
firstPackagePtr = pkgPtr->nextPtr;
ckfree(pkgPtr->fileName);
ckfree(pkgPtr->packageName);
ckfree((char *) pkgPtr);
}
}

106
cde/programs/dtdocbook/tcl/tclLoadNone.c
View file

@ -1,106 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
Tcl_Interp *interp, /* Used for error reporting. */
char *fileName, /* Name of the file containing the desired
* code. */
char *sym1, char *sym2, /* Names of two procedures to look up in
* the file's symbol table. */
Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **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(
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;
}

372
cde/programs/dtdocbook/tcl/tclMain.c
View file

@ -1,372 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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 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

116
cde/programs/dtdocbook/tcl/tclMtherr.c
View file

@ -1,116 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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.
*/
#if defined(__linux__) && defined(__GLIBC__)
# include <features.h>
/* glibc removed matherr() support between 2.26 and 2.27 */
# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 27) || __GLIBC__ >= 3
# undef NEED_MATHERR
# endif
#endif /* linux */
#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;
}

608
cde/programs/dtdocbook/tcl/tclNotify.c
View file

@ -1,608 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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(
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(
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(
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(
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(
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(
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;
}
}
}

1420
cde/programs/dtdocbook/tcl/tclParse.c
View file

File diff suppressed because it is too large Load diff

762
cde/programs/dtdocbook/tcl/tclPkg.c
View file

@ -1,762 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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(
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(
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(
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(
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(
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(
char *v1, char *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;
}
}

52
cde/programs/dtdocbook/tcl/tclPort.h
View file

@ -1,52 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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 */

1200
cde/programs/dtdocbook/tcl/tclPosixStr.c
View file

File diff suppressed because it is too large Load diff

302
cde/programs/dtdocbook/tcl/tclPreserve.c
View file

@ -1,302 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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 /* 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 /* 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 /* 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 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);
}
}

690
cde/programs/dtdocbook/tcl/tclProc.c
View file

@ -1,690 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
char **argv /* Argument strings. */
)
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr;
int result, argCount, i;
char **argArray = NULL;
Arg *lastArgPtr;
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(
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). */
)
{
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(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
char **argv /* Argument strings. */
)
{
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(
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(
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 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. */
)
{
Proc *procPtr = (Proc *) clientData;
Arg *argPtr;
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 /* 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(
Proc *procPtr /* Procedure to be deleted. */
)
{
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(
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;
}

63
cde/programs/dtdocbook/tcl/tclRegexp.h
View file

@ -1,63 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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 */

1878
cde/programs/dtdocbook/tcl/tclUnixChan.c
View file

File diff suppressed because it is too large Load diff

799
cde/programs/dtdocbook/tcl/tclUnixFile.c
View file

@ -1,799 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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_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 /* 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 /* 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(
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(
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(
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) (intptr_t) 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(
Tcl_File file /* The file to close. */
)
{
int type;
int fd;
int result;
fd = (int) (intptr_t) 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(
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) (intptr_t) 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(
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) (intptr_t) 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(
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) (intptr_t) 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(
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) (intptr_t) 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(
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(
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(
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;
}

188
cde/programs/dtdocbook/tcl/tclUnixInit.c
View file

@ -1,188 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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(
Tcl_Interp *interp /* Interpreter to initialize. */
)
{
return Tcl_Eval(interp, initScript);
}

351
cde/programs/dtdocbook/tcl/tclUnixNotfy.c
View file

@ -1,351 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(
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) (intptr_t) 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(
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) (intptr_t) 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(
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(
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(
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);
}
}

522
cde/programs/dtdocbook/tcl/tclUnixPipe.c
View file

@ -1,522 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(void)
{
#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(
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) (intptr_t) 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(
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 occurred, 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(
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) (intptr_t) pipeIds[0], TCL_UNIX_FD);
*writePipe = Tcl_GetFile((ClientData) (intptr_t) 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(
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) (intptr_t) Tcl_GetFileInfo(inFile, NULL);
Tcl_FreeFile(inFile);
} else {
*inPipePtr = -1;
}
}
if (outPipePtr) {
if (outFile) {
*outPipePtr = (int) (intptr_t) Tcl_GetFileInfo(outFile, NULL);
Tcl_FreeFile(outFile);
} else {
*outPipePtr = -1;
}
}
if (errFilePtr) {
if (errFile) {
*errFilePtr = (int) (intptr_t) Tcl_GetFileInfo(errFile, NULL);
Tcl_FreeFile(errFile);
} else {
*errFilePtr = -1;
}
}
return result;
}

436
cde/programs/dtdocbook/tcl/tclUnixPort.h
View file

@ -1,436 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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 */

88
cde/programs/dtdocbook/tcl/tclUnixSock.c
View file

@ -1,88 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(void)
{
struct utsname u;
struct hostent *hp;
if (hostnameInited) {
return hostname;
}
if (uname(&u) > -1) {
hp = gethostbyname(u.nodename);
if (hp != NULL) {
snprintf(hostname, sizeof(hostname), "%s", hp->h_name);
} else {
snprintf(hostname, sizeof(hostname), "%s", u.nodename);
}
hostnameInited = 1;
return hostname;
}
return (char *) NULL;
}

243
cde/programs/dtdocbook/tcl/tclUnixTime.c
View file

@ -1,243 +0,0 @@
/*
* CDE - Common Desktop Environment
*
* Copyright (c) 1993-2012, The Open Group. All rights reserved.
*
* These libraries and programs are free software; you can
* redistribute them and/or modify them under the terms of the GNU
* Lesser General Public License as published by the Free Software
* Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* These libraries and programs are distributed in the hope that
* they will be useful, but WITHOUT ANY WARRANTY; without even the
* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
* PURPOSE. See the GNU Lesser General Public License for more
* details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with these libraries and programs; if not, write
* to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
* Floor, Boston, MA 02110-1301 USA
*/
/* $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(void)
{
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(void)
{
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 (
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(
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;
}

2186
cde/programs/dtdocbook/tcl/tclUtil.c
View file

File diff suppressed because it is too large Load diff

2628
cde/programs/dtdocbook/tcl/tclVar.c
View file

File diff suppressed because it is too large Load diff