From: Jon Trulson Date: Sat, 22 Sep 2018 18:27:09 +0000 (-0600) Subject: Remove ancient included tcl code X-Git-Tag: 2.3.0a~26^2~1 X-Git-Url: https://git.librecmc.org/?a=commitdiff_plain;h=1fb82e33275608dbaf323ac3bfaa3ff266ead8e4;p=oweals%2Fcde.git Remove ancient included tcl code --- diff --git a/cde/programs/dtdocbook/tcl/Imakefile b/cde/programs/dtdocbook/tcl/Imakefile deleted file mode 100644 index b5e1c7c7..00000000 --- a/cde/programs/dtdocbook/tcl/Imakefile +++ /dev/null @@ -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 - -DependTarget() diff --git a/cde/programs/dtdocbook/tcl/license.terms b/cde/programs/dtdocbook/tcl/license.terms deleted file mode 100644 index 3dcd816f..00000000 --- a/cde/programs/dtdocbook/tcl/license.terms +++ /dev/null @@ -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. diff --git a/cde/programs/dtdocbook/tcl/panic.c b/cde/programs/dtdocbook/tcl/panic.c deleted file mode 100644 index 7a2064e2..00000000 --- a/cde/programs/dtdocbook/tcl/panic.c +++ /dev/null @@ -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 -#ifdef NO_STDLIB_H -# include "../compat/stdlib.h" -#else -# include -#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(); - } -} diff --git a/cde/programs/dtdocbook/tcl/patchlevel.h b/cde/programs/dtdocbook/tcl/patchlevel.h deleted file mode 100644 index 43889403..00000000 --- a/cde/programs/dtdocbook/tcl/patchlevel.h +++ /dev/null @@ -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" diff --git a/cde/programs/dtdocbook/tcl/regexp.c b/cde/programs/dtdocbook/tcl/regexp.c deleted file mode 100644 index 9933eff0..00000000 --- a/cde/programs/dtdocbook/tcl/regexp.c +++ /dev/null @@ -1,1321 +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: regexp.c /main/3 1996/10/03 11:14:58 drk $ */ -/* - * TclRegComp and TclRegExec -- TclRegSub is elsewhere - * - * Copyright (c) 1986 by University of Toronto. - * Written by Henry Spencer. Not derived from licensed software. - * - * Permission is granted to anyone to use this software for any - * purpose on any computer system, and to redistribute it freely, - * subject to the following restrictions: - * - * 1. The author is not responsible for the consequences of use of - * this software, no matter how awful, even if they arise - * from defects in it. - * - * 2. The origin of this software must not be misrepresented, either - * by explicit claim or by omission. - * - * 3. Altered versions must be plainly marked as such, and must not - * be misrepresented as being the original software. - * - * Beware that some of this code is subtly aware of the way operator - * precedence is structured in regular expressions. Serious changes in - * regular-expression syntax might require a total rethink. - * - * *** NOTE: this code has been altered slightly for use in Tcl: *** - * *** 1. Use ckalloc and ckfree instead of malloc and free. *** - * *** 2. Add extra argument to regexp to specify the real *** - * *** start of the string separately from the start of the *** - * *** current search. This is needed to search for multiple *** - * *** matches within a string. *** - * *** 3. Names have been changed, e.g. from regcomp to *** - * *** TclRegComp, to avoid clashes with other *** - * *** regexp implementations used by applications. *** - * *** 4. Added errMsg declaration and TclRegError procedure *** - * *** 5. Various lint-like things, such as casting arguments *** - * *** in procedure calls. *** - * - * *** NOTE: This code has been altered for use in MT-Sturdy Tcl *** - * *** 1. All use of static variables has been changed to access *** - * *** fields of a structure. *** - * *** 2. This in addition to changes to TclRegError makes the *** - * *** code multi-thread safe. *** - * - * SCCS: @(#) regexp.c 1.12 96/04/02 13:54:57 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * The variable below is set to NULL before invoking regexp functions - * and checked after those functions. If an error occurred then TclRegError - * will set the variable to point to a (static) error message. This - * mechanism unfortunately does not support multi-threading, but the - * procedures TclRegError and TclGetRegError can be modified to use - * thread-specific storage for the variable and thereby make the code - * thread-safe. - */ - -static char *errMsg = NULL; - -/* - * The "internal use only" fields in regexp.h are present to pass info from - * compile to execute that permits the execute phase to run lots faster on - * simple cases. They are: - * - * regstart char that must begin a match; '\0' if none obvious - * reganch is the match anchored (at beginning-of-line only)? - * regmust string (pointer into program) that match must include, or NULL - * regmlen length of regmust string - * - * Regstart and reganch permit very fast decisions on suitable starting points - * for a match, cutting down the work a lot. Regmust permits fast rejection - * of lines that cannot possibly match. The regmust tests are costly enough - * that TclRegComp() supplies a regmust only if the r.e. contains something - * potentially expensive (at present, the only such thing detected is * or + - * at the start of the r.e., which can involve a lot of backup). Regmlen is - * supplied because the test in TclRegExec() needs it and TclRegComp() is - * computing it anyway. - */ - -/* - * Structure for regexp "program". This is essentially a linear encoding - * of a nondeterministic finite-state machine (aka syntax charts or - * "railroad normal form" in parsing technology). Each node is an opcode - * plus a "next" pointer, possibly plus an operand. "Next" pointers of - * all nodes except BRANCH implement concatenation; a "next" pointer with - * a BRANCH on both ends of it is connecting two alternatives. (Here we - * have one of the subtle syntax dependencies: an individual BRANCH (as - * opposed to a collection of them) is never concatenated with anything - * because of operator precedence.) The operand of some types of node is - * a literal string; for others, it is a node leading into a sub-FSM. In - * particular, the operand of a BRANCH node is the first node of the branch. - * (NB this is *not* a tree structure: the tail of the branch connects - * to the thing following the set of BRANCHes.) The opcodes are: - */ - -/* definition number opnd? meaning */ -#define END 0 /* no End of program. */ -#define BOL 1 /* no Match "" at beginning of line. */ -#define EOL 2 /* no Match "" at end of line. */ -#define ANY 3 /* no Match any one character. */ -#define ANYOF 4 /* str Match any character in this string. */ -#define ANYBUT 5 /* str Match any character not in this string. */ -#define BRANCH 6 /* node Match this alternative, or the next... */ -#define BACK 7 /* no Match "", "next" ptr points backward. */ -#define EXACTLY 8 /* str Match this string. */ -#define NOTHING 9 /* no Match empty string. */ -#define STAR 10 /* node Match this (simple) thing 0 or more times. */ -#define PLUS 11 /* node Match this (simple) thing 1 or more times. */ -#define OPEN 20 /* no Mark this point in input as start of #n. */ - /* OPEN+1 is number 1, etc. */ -#define CLOSE (OPEN+NSUBEXP) /* no Analogous to OPEN. */ - -/* - * Opcode notes: - * - * BRANCH The set of branches constituting a single choice are hooked - * together with their "next" pointers, since precedence prevents - * anything being concatenated to any individual branch. The - * "next" pointer of the last BRANCH in a choice points to the - * thing following the whole choice. This is also where the - * final "next" pointer of each individual branch points; each - * branch starts with the operand node of a BRANCH node. - * - * BACK Normal "next" pointers all implicitly point forward; BACK - * exists to make loop structures possible. - * - * STAR,PLUS '?', and complex '*' and '+', are implemented as circular - * BRANCH structures using BACK. Simple cases (one character - * per match) are implemented with STAR and PLUS for speed - * and to minimize recursive plunges. - * - * OPEN,CLOSE ...are numbered at compile time. - */ - -/* - * A node is one char of opcode followed by two chars of "next" pointer. - * "Next" pointers are stored as two 8-bit pieces, high order first. The - * value is a positive offset from the opcode of the node containing it. - * An operand, if any, simply follows the node. (Note that much of the - * code generation knows about this implicit relationship.) - * - * Using two bytes for the "next" pointer is vast overkill for most things, - * but allows patterns to get big without disasters. - */ -#define OP(p) (*(p)) -#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377)) -#define OPERAND(p) ((p) + 3) - -/* - * See regmagic.h for one further detail of program structure. - */ - - -/* - * Utility definitions. - */ -#ifndef CHARBITS -#define UCHARAT(p) ((int)*(unsigned char *)(p)) -#else -#define UCHARAT(p) ((int)*(p)&CHARBITS) -#endif - -#define FAIL(m) { TclRegError(m); return(NULL); } -#define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?') -#define META "^$.[()|?+*\\" - -/* - * Flags to be passed up and down. - */ -#define HASWIDTH 01 /* Known never to match null string. */ -#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ -#define SPSTART 04 /* Starts with * or +. */ -#define WORST 0 /* Worst case. */ - -/* - * Global work variables for TclRegComp(). - */ -struct regcomp_state { - char *regparse; /* Input-scan pointer. */ - int regnpar; /* () count. */ - char *regcode; /* Code-emit pointer; ®dummy = don't. */ - long regsize; /* Code size. */ -}; - -static char regdummy; - -/* - * The first byte of the regexp internal "program" is actually this magic - * number; the start node begins in the second byte. - */ -#define MAGIC 0234 - - -/* - * Forward declarations for TclRegComp()'s friends. - */ - -static char * reg _ANSI_ARGS_((int paren, int *flagp, - struct regcomp_state *rcstate)); -static char * regatom _ANSI_ARGS_((int *flagp, - struct regcomp_state *rcstate)); -static char * regbranch _ANSI_ARGS_((int *flagp, - struct regcomp_state *rcstate)); -static void regc _ANSI_ARGS_((int b, - struct regcomp_state *rcstate)); -static void reginsert _ANSI_ARGS_((int op, char *opnd, - struct regcomp_state *rcstate)); -static char * regnext _ANSI_ARGS_((char *p)); -static char * regnode _ANSI_ARGS_((int op, - struct regcomp_state *rcstate)); -static void regoptail _ANSI_ARGS_((char *p, char *val)); -static char * regpiece _ANSI_ARGS_((int *flagp, - struct regcomp_state *rcstate)); -static void regtail _ANSI_ARGS_((char *p, char *val)); - -#ifdef STRCSPN -static int strcspn _ANSI_ARGS_((char *s1, char *s2)); -#endif - -/* - - TclRegComp - compile a regular expression into internal code - * - * We can't allocate space until we know how big the compiled form will be, - * but we can't compile it (and thus know how big it is) until we've got a - * place to put the code. So we cheat: we compile it twice, once with code - * generation turned off and size counting turned on, and once "for real". - * This also means that we don't allocate space until we are sure that the - * thing really will compile successfully, and we never have to move the - * code and thus invalidate pointers into it. (Note that it has to be in - * one piece because free() must be able to free it all.) - * - * Beware that the optimization-preparation code in here knows about some - * of the structure of the compiled regexp. - */ -regexp * -TclRegComp(char *exp) -{ - regexp *r; - char *scan; - char *longest; - int len; - int flags; - struct regcomp_state state; - struct regcomp_state *rcstate= &state; - - if (exp == NULL) - FAIL("NULL argument"); - - /* First pass: determine size, legality. */ - rcstate->regparse = exp; - rcstate->regnpar = 1; - rcstate->regsize = 0L; - rcstate->regcode = ®dummy; - regc(MAGIC, rcstate); - if (reg(0, &flags, rcstate) == NULL) - return(NULL); - - /* Small enough for pointer-storage convention? */ - if (rcstate->regsize >= 32767L) /* Probably could be 65535L. */ - FAIL("regexp too big"); - - /* Allocate space. */ - r = (regexp *)ckalloc(sizeof(regexp) + (unsigned)rcstate->regsize); - if (r == NULL) - FAIL("out of space"); - - /* Second pass: emit code. */ - rcstate->regparse = exp; - rcstate->regnpar = 1; - rcstate->regcode = r->program; - regc(MAGIC, rcstate); - if (reg(0, &flags, rcstate) == NULL) - return(NULL); - - /* Dig out information for optimizations. */ - r->regstart = '\0'; /* Worst-case defaults. */ - r->reganch = 0; - r->regmust = NULL; - r->regmlen = 0; - scan = r->program+1; /* First BRANCH. */ - if (OP(regnext(scan)) == END) { /* Only one top-level choice. */ - scan = OPERAND(scan); - - /* Starting-point info. */ - if (OP(scan) == EXACTLY) - r->regstart = *OPERAND(scan); - else if (OP(scan) == BOL) - r->reganch++; - - /* - * If there's something expensive in the r.e., find the - * longest literal string that must appear and make it the - * regmust. Resolve ties in favor of later strings, since - * the regstart check works with the beginning of the r.e. - * and avoiding duplication strengthens checking. Not a - * strong reason, but sufficient in the absence of others. - */ - if (flags&SPSTART) { - longest = NULL; - len = 0; - for (; scan != NULL; scan = regnext(scan)) - if (OP(scan) == EXACTLY && ((int) strlen(OPERAND(scan))) >= len) { - longest = OPERAND(scan); - len = strlen(OPERAND(scan)); - } - r->regmust = longest; - r->regmlen = len; - } - } - - return(r); -} - -/* - - reg - regular expression, i.e. main body or parenthesized thing - * - * Caller must absorb opening parenthesis. - * - * Combining parenthesis handling with the base level of regular expression - * is a trifle forced, but the need to tie the tails of the branches to what - * follows makes it hard to avoid. - */ -static char * -reg(int paren /* Parenthesized? */, int *flagp, struct regcomp_state *rcstate) -{ - char *ret; - char *br; - char *ender; - int parno = 0; - int flags; - - *flagp = HASWIDTH; /* Tentatively. */ - - /* Make an OPEN node, if parenthesized. */ - if (paren) { - if (rcstate->regnpar >= NSUBEXP) - FAIL("too many ()"); - parno = rcstate->regnpar; - rcstate->regnpar++; - ret = regnode(OPEN+parno,rcstate); - } else - ret = NULL; - - /* Pick up the branches, linking them together. */ - br = regbranch(&flags,rcstate); - if (br == NULL) - return(NULL); - if (ret != NULL) - regtail(ret, br); /* OPEN -> first. */ - else - ret = br; - if (!(flags&HASWIDTH)) - *flagp &= ~HASWIDTH; - *flagp |= flags&SPSTART; - while (*rcstate->regparse == '|') { - rcstate->regparse++; - br = regbranch(&flags,rcstate); - if (br == NULL) - return(NULL); - regtail(ret, br); /* BRANCH -> BRANCH. */ - if (!(flags&HASWIDTH)) - *flagp &= ~HASWIDTH; - *flagp |= flags&SPSTART; - } - - /* Make a closing node, and hook it on the end. */ - ender = regnode((paren) ? CLOSE+parno : END,rcstate); - regtail(ret, ender); - - /* Hook the tails of the branches to the closing node. */ - for (br = ret; br != NULL; br = regnext(br)) - regoptail(br, ender); - - /* Check for proper termination. */ - if (paren && *rcstate->regparse++ != ')') { - FAIL("unmatched ()"); - } else if (!paren && *rcstate->regparse != '\0') { - if (*rcstate->regparse == ')') { - FAIL("unmatched ()"); - } else - FAIL("junk on end"); /* "Can't happen". */ - /* NOTREACHED */ - } - - return(ret); -} - -/* - - regbranch - one alternative of an | operator - * - * Implements the concatenation operator. - */ -static char * -regbranch(int *flagp, struct regcomp_state *rcstate) -{ - char *ret; - char *chain; - char *latest; - int flags; - - *flagp = WORST; /* Tentatively. */ - - ret = regnode(BRANCH,rcstate); - chain = NULL; - while (*rcstate->regparse != '\0' && *rcstate->regparse != '|' && - *rcstate->regparse != ')') { - latest = regpiece(&flags, rcstate); - if (latest == NULL) - return(NULL); - *flagp |= flags&HASWIDTH; - if (chain == NULL) /* First piece. */ - *flagp |= flags&SPSTART; - else - regtail(chain, latest); - chain = latest; - } - if (chain == NULL) /* Loop ran zero times. */ - (void) regnode(NOTHING,rcstate); - - return(ret); -} - -/* - - regpiece - something followed by possible [*+?] - * - * Note that the branching code sequences used for ? and the general cases - * of * and + are somewhat optimized: they use the same NOTHING node as - * both the endmarker for their branch list and the body of the last branch. - * It might seem that this node could be dispensed with entirely, but the - * endmarker role is not redundant. - */ -static char * -regpiece(int *flagp, struct regcomp_state *rcstate) -{ - char *ret; - char op; - char *next; - int flags; - - ret = regatom(&flags,rcstate); - if (ret == NULL) - return(NULL); - - op = *rcstate->regparse; - if (!ISMULT(op)) { - *flagp = flags; - return(ret); - } - - if (!(flags&HASWIDTH) && op != '?') - FAIL("*+ operand could be empty"); - *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); - - if (op == '*' && (flags&SIMPLE)) - reginsert(STAR, ret, rcstate); - else if (op == '*') { - /* Emit x* as (x&|), where & means "self". */ - reginsert(BRANCH, ret, rcstate); /* Either x */ - regoptail(ret, regnode(BACK,rcstate)); /* and loop */ - regoptail(ret, ret); /* back */ - regtail(ret, regnode(BRANCH,rcstate)); /* or */ - regtail(ret, regnode(NOTHING,rcstate)); /* null. */ - } else if (op == '+' && (flags&SIMPLE)) - reginsert(PLUS, ret, rcstate); - else if (op == '+') { - /* Emit x+ as x(&|), where & means "self". */ - next = regnode(BRANCH,rcstate); /* Either */ - regtail(ret, next); - regtail(regnode(BACK,rcstate), ret); /* loop back */ - regtail(next, regnode(BRANCH,rcstate)); /* or */ - regtail(ret, regnode(NOTHING,rcstate)); /* null. */ - } else if (op == '?') { - /* Emit x? as (x|) */ - reginsert(BRANCH, ret, rcstate); /* Either x */ - regtail(ret, regnode(BRANCH,rcstate)); /* or */ - next = regnode(NOTHING,rcstate); /* null. */ - regtail(ret, next); - regoptail(ret, next); - } - rcstate->regparse++; - if (ISMULT(*rcstate->regparse)) - FAIL("nested *?+"); - - return(ret); -} - -/* - - regatom - the lowest level - * - * Optimization: gobbles an entire sequence of ordinary characters so that - * it can turn them into a single node, which is smaller to store and - * faster to run. Backslashed characters are exceptions, each becoming a - * separate node; the code is simpler that way and it's not worth fixing. - */ -static char * -regatom(int *flagp, struct regcomp_state *rcstate) -{ - char *ret; - int flags; - - *flagp = WORST; /* Tentatively. */ - - switch (*rcstate->regparse++) { - case '^': - ret = regnode(BOL,rcstate); - break; - case '$': - ret = regnode(EOL,rcstate); - break; - case '.': - ret = regnode(ANY,rcstate); - *flagp |= HASWIDTH|SIMPLE; - break; - case '[': { - int clss; - int classend; - - if (*rcstate->regparse == '^') { /* Complement of range. */ - ret = regnode(ANYBUT,rcstate); - rcstate->regparse++; - } else - ret = regnode(ANYOF,rcstate); - if (*rcstate->regparse == ']' || *rcstate->regparse == '-') - regc(*rcstate->regparse++,rcstate); - while (*rcstate->regparse != '\0' && *rcstate->regparse != ']') { - if (*rcstate->regparse == '-') { - rcstate->regparse++; - if (*rcstate->regparse == ']' || *rcstate->regparse == '\0') - regc('-',rcstate); - else { - clss = UCHARAT(rcstate->regparse-2)+1; - classend = UCHARAT(rcstate->regparse); - if (clss > classend+1) - FAIL("invalid [] range"); - for (; clss <= classend; clss++) - regc((char)clss,rcstate); - rcstate->regparse++; - } - } else - regc(*rcstate->regparse++,rcstate); - } - regc('\0',rcstate); - if (*rcstate->regparse != ']') - FAIL("unmatched []"); - rcstate->regparse++; - *flagp |= HASWIDTH|SIMPLE; - } - break; - case '(': - ret = reg(1, &flags, rcstate); - if (ret == NULL) - return(NULL); - *flagp |= flags&(HASWIDTH|SPSTART); - break; - case '\0': - case '|': - case ')': - FAIL("internal urp"); /* Supposed to be caught earlier. */ - /* NOTREACHED */ - break; - case '?': - case '+': - case '*': - FAIL("?+* follows nothing"); - /* NOTREACHED */ - break; - case '\\': - if (*rcstate->regparse == '\0') - FAIL("trailing \\"); - ret = regnode(EXACTLY,rcstate); - regc(*rcstate->regparse++,rcstate); - regc('\0',rcstate); - *flagp |= HASWIDTH|SIMPLE; - break; - default: { - int len; - char ender; - - rcstate->regparse--; - len = strcspn(rcstate->regparse, META); - if (len <= 0) - FAIL("internal disaster"); - ender = *(rcstate->regparse+len); - if (len > 1 && ISMULT(ender)) - len--; /* Back off clear of ?+* operand. */ - *flagp |= HASWIDTH; - if (len == 1) - *flagp |= SIMPLE; - ret = regnode(EXACTLY,rcstate); - while (len > 0) { - regc(*rcstate->regparse++,rcstate); - len--; - } - regc('\0',rcstate); - } - break; - } - - return(ret); -} - -/* - - regnode - emit a node - */ -static char * /* Location. */ -regnode(int op, struct regcomp_state *rcstate) -{ - char *ret; - char *ptr; - - ret = rcstate->regcode; - if (ret == ®dummy) { - rcstate->regsize += 3; - return(ret); - } - - ptr = ret; - *ptr++ = (char)op; - *ptr++ = '\0'; /* Null "next" pointer. */ - *ptr++ = '\0'; - rcstate->regcode = ptr; - - return(ret); -} - -/* - - regc - emit (if appropriate) a byte of code - */ -static void -regc(int b, struct regcomp_state *rcstate) -{ - if (rcstate->regcode != ®dummy) - *rcstate->regcode++ = (char)b; - else - rcstate->regsize++; -} - -/* - - reginsert - insert an operator in front of already-emitted operand - * - * Means relocating the operand. - */ -static void -reginsert(int op, char *opnd, struct regcomp_state *rcstate) -{ - char *src; - char *dst; - char *place; - - if (rcstate->regcode == ®dummy) { - rcstate->regsize += 3; - return; - } - - src = rcstate->regcode; - rcstate->regcode += 3; - dst = rcstate->regcode; - while (src > opnd) - *--dst = *--src; - - place = opnd; /* Op node, where operand used to be. */ - *place++ = (char)op; - *place++ = '\0'; - *place = '\0'; -} - -/* - - regtail - set the next-pointer at the end of a node chain - */ -static void -regtail(char *p, char *val) -{ - char *scan; - char *temp; - int offset; - - if (p == ®dummy) - return; - - /* Find last node. */ - scan = p; - for (;;) { - temp = regnext(scan); - if (temp == NULL) - break; - scan = temp; - } - - if (OP(scan) == BACK) - offset = scan - val; - else - offset = val - scan; - *(scan+1) = (char)((offset>>8)&0377); - *(scan+2) = (char)(offset&0377); -} - -/* - - regoptail - regtail on operand of first argument; nop if operandless - */ -static void -regoptail(char *p, char *val) -{ - /* "Operandless" and "op != BRANCH" are synonymous in practice. */ - if (p == NULL || p == ®dummy || OP(p) != BRANCH) - return; - regtail(OPERAND(p), val); -} - -/* - * TclRegExec and friends - */ - -/* - * Global work variables for TclRegExec(). - */ -struct regexec_state { - char *reginput; /* String-input pointer. */ - char *regbol; /* Beginning of input, for ^ check. */ - char **regstartp; /* Pointer to startp array. */ - char **regendp; /* Ditto for endp. */ -}; - -/* - * Forwards. - */ -static int regtry _ANSI_ARGS_((regexp *prog, char *string, - struct regexec_state *restate)); -static int regmatch _ANSI_ARGS_((char *prog, - struct regexec_state *restate)); -static int regrepeat _ANSI_ARGS_((char *p, - struct regexec_state *restate)); - -#ifdef DEBUG -int regnarrate = 0; -void regdump _ANSI_ARGS_((regexp *r)); -static char *regprop _ANSI_ARGS_((char *op)); -#endif - -/* - - TclRegExec - match a regexp against a string - */ -int -TclRegExec(regexp *prog, char *string, char *start) -{ - char *s; - struct regexec_state state; - struct regexec_state *restate= &state; - - /* Be paranoid... */ - if (prog == NULL || string == NULL) { - TclRegError("NULL parameter"); - return(0); - } - - /* Check validity of program. */ - if (UCHARAT(prog->program) != MAGIC) { - TclRegError("corrupted program"); - return(0); - } - - /* If there is a "must appear" string, look for it. */ - if (prog->regmust != NULL) { - s = string; - while ((s = strchr(s, prog->regmust[0])) != NULL) { - if (strncmp(s, prog->regmust, (size_t) prog->regmlen) - == 0) - break; /* Found it. */ - s++; - } - if (s == NULL) /* Not present. */ - return(0); - } - - /* Mark beginning of line for ^ . */ - restate->regbol = start; - - /* Simplest case: anchored match need be tried only once. */ - if (prog->reganch) - return(regtry(prog, string, restate)); - - /* Messy cases: unanchored match. */ - s = string; - if (prog->regstart != '\0') - /* We know what char it must start with. */ - while ((s = strchr(s, prog->regstart)) != NULL) { - if (regtry(prog, s, restate)) - return(1); - s++; - } - else - /* We don't -- general case. */ - do { - if (regtry(prog, s, restate)) - return(1); - } while (*s++ != '\0'); - - /* Failure. */ - return(0); -} - -/* - - regtry - try match at specific point - */ -static int /* 0 failure, 1 success */ -regtry(regexp *prog, char *string, struct regexec_state *restate) -{ - int i; - char **sp; - char **ep; - - restate->reginput = string; - restate->regstartp = prog->startp; - restate->regendp = prog->endp; - - sp = prog->startp; - ep = prog->endp; - for (i = NSUBEXP; i > 0; i--) { - *sp++ = NULL; - *ep++ = NULL; - } - if (regmatch(prog->program + 1,restate)) { - prog->startp[0] = string; - prog->endp[0] = restate->reginput; - return(1); - } else - return(0); -} - -/* - - regmatch - main matching routine - * - * Conceptually the strategy is simple: check to see whether the current - * node matches, call self recursively to see whether the rest matches, - * and then act accordingly. In practice we make some effort to avoid - * recursion, in particular by going through "ordinary" nodes (that don't - * need to know whether the rest of the match failed) by a loop instead of - * by recursion. - */ -static int /* 0 failure, 1 success */ -regmatch(char *prog, struct regexec_state *restate) -{ - char *scan; /* Current node. */ - char *next; /* Next node. */ - - scan = prog; -#ifdef DEBUG - if (scan != NULL && regnarrate) - fprintf(stderr, "%s(\n", regprop(scan)); -#endif - while (scan != NULL) { -#ifdef DEBUG - if (regnarrate) - fprintf(stderr, "%s...\n", regprop(scan)); -#endif - next = regnext(scan); - - switch (OP(scan)) { - case BOL: - if (restate->reginput != restate->regbol) { - return 0; - } - break; - case EOL: - if (*restate->reginput != '\0') { - return 0; - } - break; - case ANY: - if (*restate->reginput == '\0') { - return 0; - } - restate->reginput++; - break; - case EXACTLY: { - int len; - char *opnd; - - opnd = OPERAND(scan); - /* Inline the first character, for speed. */ - if (*opnd != *restate->reginput) { - return 0 ; - } - len = strlen(opnd); - if (len > 1 && strncmp(opnd, restate->reginput, (size_t) len) - != 0) { - return 0; - } - restate->reginput += len; - break; - } - case ANYOF: - if (*restate->reginput == '\0' - || strchr(OPERAND(scan), *restate->reginput) == NULL) { - return 0; - } - restate->reginput++; - break; - case ANYBUT: - if (*restate->reginput == '\0' - || strchr(OPERAND(scan), *restate->reginput) != NULL) { - return 0; - } - restate->reginput++; - break; - case NOTHING: - break; - case BACK: - break; - case OPEN+1: - case OPEN+2: - case OPEN+3: - case OPEN+4: - case OPEN+5: - case OPEN+6: - case OPEN+7: - case OPEN+8: - case OPEN+9: { - int no; - char *save; - - doOpen: - no = OP(scan) - OPEN; - save = restate->reginput; - - if (regmatch(next,restate)) { - /* - * Don't set startp if some later invocation of the - * same parentheses already has. - */ - if (restate->regstartp[no] == NULL) { - restate->regstartp[no] = save; - } - return 1; - } else { - return 0; - } - } - case CLOSE+1: - case CLOSE+2: - case CLOSE+3: - case CLOSE+4: - case CLOSE+5: - case CLOSE+6: - case CLOSE+7: - case CLOSE+8: - case CLOSE+9: { - int no; - char *save; - - doClose: - no = OP(scan) - CLOSE; - save = restate->reginput; - - if (regmatch(next,restate)) { - /* - * Don't set endp if some later - * invocation of the same parentheses - * already has. - */ - if (restate->regendp[no] == NULL) - restate->regendp[no] = save; - return 1; - } else { - return 0; - } - } - case BRANCH: { - char *save; - - if (OP(next) != BRANCH) { /* No choice. */ - next = OPERAND(scan); /* Avoid recursion. */ - } else { - do { - save = restate->reginput; - if (regmatch(OPERAND(scan),restate)) - return(1); - restate->reginput = save; - scan = regnext(scan); - } while (scan != NULL && OP(scan) == BRANCH); - return 0; - } - break; - } - case STAR: - case PLUS: { - char nextch; - int no; - char *save; - int min; - - /* - * Lookahead to avoid useless match attempts - * when we know what character comes next. - */ - nextch = '\0'; - if (OP(next) == EXACTLY) - nextch = *OPERAND(next); - min = (OP(scan) == STAR) ? 0 : 1; - save = restate->reginput; - no = regrepeat(OPERAND(scan),restate); - while (no >= min) { - /* If it could work, try it. */ - if (nextch == '\0' || *restate->reginput == nextch) - if (regmatch(next,restate)) - return(1); - /* Couldn't or didn't -- back up. */ - no--; - restate->reginput = save + no; - } - return(0); - } - case END: - return(1); /* Success! */ - default: - if (OP(scan) > OPEN && OP(scan) < OPEN+NSUBEXP) { - goto doOpen; - } else if (OP(scan) > CLOSE && OP(scan) < CLOSE+NSUBEXP) { - goto doClose; - } - TclRegError("memory corruption"); - return 0; - } - - scan = next; - } - - /* - * We get here only if there's trouble -- normally "case END" is - * the terminating point. - */ - TclRegError("corrupted pointers"); - return(0); -} - -/* - - regrepeat - repeatedly match something simple, report how many - */ -static int -regrepeat(char *p, struct regexec_state *restate) -{ - int count = 0; - char *scan; - char *opnd; - - scan = restate->reginput; - opnd = OPERAND(p); - switch (OP(p)) { - case ANY: - count = strlen(scan); - scan += count; - break; - case EXACTLY: - while (*opnd == *scan) { - count++; - scan++; - } - break; - case ANYOF: - while (*scan != '\0' && strchr(opnd, *scan) != NULL) { - count++; - scan++; - } - break; - case ANYBUT: - while (*scan != '\0' && strchr(opnd, *scan) == NULL) { - count++; - scan++; - } - break; - default: /* Oh dear. Called inappropriately. */ - TclRegError("internal foulup"); - count = 0; /* Best compromise. */ - break; - } - restate->reginput = scan; - - return(count); -} - -/* - - regnext - dig the "next" pointer out of a node - */ -static char * -regnext(char *p) -{ - int offset; - - if (p == ®dummy) - return(NULL); - - offset = NEXT(p); - if (offset == 0) - return(NULL); - - if (OP(p) == BACK) - return(p-offset); - else - return(p+offset); -} - -#ifdef DEBUG - -static char *regprop(); - -/* - - regdump - dump a regexp onto stdout in vaguely comprehensible form - */ -void -regdump(regexp *r) -{ - char *s; - char op = EXACTLY; /* Arbitrary non-END op. */ - char *next; - - - s = r->program + 1; - while (op != END) { /* While that wasn't END last time... */ - op = OP(s); - printf("%2ld%s", (long) s-r->program, regprop(s)); /* Where, what. */ - next = regnext(s); - if (next == NULL) /* Next ptr. */ - printf("(0)"); - else - printf("(%ld)", (long) (s-r->program)+(next-s)); - s += 3; - if (op == ANYOF || op == ANYBUT || op == EXACTLY) { - /* Literal string, where present. */ - while (*s != '\0') { - putchar(*s); - s++; - } - s++; - } - putchar('\n'); - } - - /* Header fields of interest. */ - if (r->regstart != '\0') - printf("start `%c' ", r->regstart); - if (r->reganch) - printf("anchored "); - if (r->regmust != NULL) - printf("must have \"%s\"", r->regmust); - printf("\n"); -} - -/* - - regprop - printable representation of opcode - */ -static char * -regprop(char *op) -{ - char *p; - static char buf[50]; - - (void) strcpy(buf, ":"); - - switch (OP(op)) { - case BOL: - p = "BOL"; - break; - case EOL: - p = "EOL"; - break; - case ANY: - p = "ANY"; - break; - case ANYOF: - p = "ANYOF"; - break; - case ANYBUT: - p = "ANYBUT"; - break; - case BRANCH: - p = "BRANCH"; - break; - case EXACTLY: - p = "EXACTLY"; - break; - case NOTHING: - p = "NOTHING"; - break; - case BACK: - p = "BACK"; - break; - case END: - p = "END"; - break; - case OPEN+1: - case OPEN+2: - case OPEN+3: - case OPEN+4: - case OPEN+5: - case OPEN+6: - case OPEN+7: - case OPEN+8: - case OPEN+9: - sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); - p = NULL; - break; - case CLOSE+1: - case CLOSE+2: - case CLOSE+3: - case CLOSE+4: - case CLOSE+5: - case CLOSE+6: - case CLOSE+7: - case CLOSE+8: - case CLOSE+9: - sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); - p = NULL; - break; - case STAR: - p = "STAR"; - break; - case PLUS: - p = "PLUS"; - break; - default: - if (OP(op) > OPEN && OP(op) < OPEN+NSUBEXP) { - sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); - p = NULL; - break; - } else if (OP(op) > CLOSE && OP(op) < CLOSE+NSUBEXP) { - sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); - p = NULL; - } else { - TclRegError("corrupted opcode"); - } - break; - } - if (p != NULL) - (void) strcat(buf, p); - return(buf); -} -#endif - -/* - * The following is provided for those people who do not have strcspn() in - * their C libraries. They should get off their butts and do something - * about it; at least one public-domain implementation of those (highly - * useful) string routines has been published on Usenet. - */ -#ifdef STRCSPN -/* - * strcspn - find length of initial segment of s1 consisting entirely - * of characters not from s2 - */ - -static int -strcspn(char *s1, char *s2) -{ - char *scan1; - char *scan2; - int count; - - count = 0; - for (scan1 = s1; *scan1 != '\0'; scan1++) { - for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */ - if (*scan1 == *scan2++) - return(count); - count++; - } - return(count); -} -#endif - -/* - *---------------------------------------------------------------------- - * - * TclRegError -- - * - * This procedure is invoked by the regexp code when an error - * occurs. It saves the error message so it can be seen by the - * code that called Spencer's code. - * - * Results: - * None. - * - * Side effects: - * The value of "string" is saved in "errMsg". - * - *---------------------------------------------------------------------- - */ - -void -TclRegError(char *string /* Error message. */) -{ - errMsg = string; -} - -char * -TclGetRegError(void) -{ - return errMsg; -} diff --git a/cde/programs/dtdocbook/tcl/tcl.h b/cde/programs/dtdocbook/tcl/tcl.h deleted file mode 100644 index 819e5acc..00000000 --- a/cde/programs/dtdocbook/tcl/tcl.h +++ /dev/null @@ -1,1087 +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: tcl.h /main/4 1996/10/04 10:01:47 drk $ */ -/* - * tcl.h -- - * - * This header file describes the externally-visible facilities - * of the Tcl interpreter. - * - * Copyright (c) 1987-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: @(#) tcl.h 1.266 96/04/10 11:25:19 - */ - -#ifndef _TCL -#define _TCL - -/* - * The following definitions set up the proper options for Windows - * compilers. We use this method because there is no autoconf equivalent. - */ - -#if defined(_WIN32) && !defined(__WIN32__) -# define __WIN32__ -#endif - -#ifdef __WIN32__ -# undef USE_PROTOTYPE -# undef HAS_STDARG -# define USE_PROTOTYPE -# define HAS_STDARG -#endif - -#ifndef BUFSIZ -#include -#endif - -#include /* for pid_t */ - -#define TCL_VERSION "7.5" -#define TCL_MAJOR_VERSION 7 -#define TCL_MINOR_VERSION 5 - -/* - * Definitions that allow Tcl functions with variable numbers of - * arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS - * is used in procedure prototypes. TCL_VARARGS_DEF is used to declare - * the arguments in a function definiton: it takes the type and name of - * the first argument and supplies the appropriate argument declaration - * string for use in the function definition. TCL_VARARGS_START - * initializes the va_list data structure and returns the first argument. - */ - -#if defined(__STDC__) || defined(HAS_STDARG) -# define TCL_VARARGS(type, name) (type name, ...) -# define TCL_VARARGS_DEF(type, name) (type name, ...) -# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) -#else -# ifdef __cplusplus -# define TCL_VARARGS(type, name) (type name, ...) -# define TCL_VARARGS_DEF(type, name) (type va_alist, ...) -# else -# define TCL_VARARGS(type, name) () -# define TCL_VARARGS_DEF(type, name) (va_alist) -# endif -# define TCL_VARARGS_START(type, name, list) \ - (va_start(list), va_arg(list, type)) -#endif - -/* - * Definitions that allow this header file to be used either with or - * without ANSI C features like function prototypes. - */ - -#undef _ANSI_ARGS_ -#undef CONST - -#if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) || defined(USE_PROTOTYPE) -# define _USING_PROTOTYPES_ 1 -# define _ANSI_ARGS_(x) x -# define CONST const -#else -# define _ANSI_ARGS_(x) () -# define CONST -#endif - -#ifdef __cplusplus -# define EXTERN extern "C" -#else -# define EXTERN extern -#endif - -/* - * Macro to use instead of "void" for arguments that must have - * type "void *" in ANSI C; maps them to type "char *" in - * non-ANSI systems. - */ -#ifndef __WIN32__ -#ifndef VOID -# ifdef __STDC__ -# define VOID void -# else -# define VOID char -# endif -#endif -#else /* __WIN32__ */ -/* - * The following code is copied from winnt.h - */ -#ifndef VOID -#define VOID void -typedef char CHAR; -typedef short SHORT; -typedef long LONG; -#endif -#endif /* __WIN32__ */ - -/* - * Miscellaneous declarations. - */ - -#ifndef NULL -#define NULL 0 -#endif - -#ifndef _CLIENTDATA -# if defined(__STDC__) || defined(__cplusplus) - typedef void *ClientData; -# else - typedef int *ClientData; -# endif /* __STDC__ */ -#define _CLIENTDATA -#endif - -/* - * Data structures defined opaquely in this module. The definitions - * below just provide dummy types. A few fields are made visible in - * Tcl_Interp structures, namely those for returning string values. - * Note: any change to the Tcl_Interp definition below must be mirrored - * in the "real" definition in tclInt.h. - */ - -typedef struct Tcl_Interp{ - char *result; /* Points to result string returned by last - * command. */ - void (*freeProc) _ANSI_ARGS_((char *blockPtr)); - /* Zero means result is statically allocated. - * TCL_DYNAMIC means result was allocated with - * ckalloc and should be freed with ckfree. - * Other values give address of procedure - * to invoke to free the result. Must be - * freed by Tcl_Eval before executing next - * command. */ - int errorLine; /* When TCL_ERROR is returned, this gives - * the line number within the command where - * the error occurred (1 means first line). */ -} Tcl_Interp; - -typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; -typedef struct Tcl_Command_ *Tcl_Command; -typedef struct Tcl_Event Tcl_Event; -typedef struct Tcl_File_ *Tcl_File; -typedef struct Tcl_Channel_ *Tcl_Channel; -typedef struct Tcl_RegExp_ *Tcl_RegExp; -typedef struct Tcl_TimerToken_ *Tcl_TimerToken; -typedef struct Tcl_Trace_ *Tcl_Trace; - -/* - * When a TCL command returns, the string pointer interp->result points to - * a string containing return information from the command. In addition, - * the command procedure returns an integer value, which is one of the - * following: - * - * TCL_OK Command completed normally; interp->result contains - * the command's result. - * TCL_ERROR The command couldn't be completed successfully; - * interp->result describes what went wrong. - * TCL_RETURN The command requests that the current procedure - * return; interp->result contains the procedure's - * return value. - * TCL_BREAK The command requests that the innermost loop - * be exited; interp->result is meaningless. - * TCL_CONTINUE Go on to the next iteration of the current loop; - * interp->result is meaningless. - */ - -#define TCL_OK 0 -#define TCL_ERROR 1 -#define TCL_RETURN 2 -#define TCL_BREAK 3 -#define TCL_CONTINUE 4 - -#define TCL_RESULT_SIZE 200 - -/* - * Argument descriptors for math function callbacks in expressions: - */ - -typedef enum {TCL_INT, TCL_DOUBLE, TCL_EITHER} Tcl_ValueType; -typedef struct Tcl_Value { - Tcl_ValueType type; /* Indicates intValue or doubleValue is - * valid, or both. */ - long intValue; /* Integer value. */ - double doubleValue; /* Double-precision floating value. */ -} Tcl_Value; - -/* - * Procedure types defined by Tcl: - */ - -typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); -typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int code)); -typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask)); -typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data)); -typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData)); -typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char *argv[])); -typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, - ClientData cmdClientData, int argc, char *argv[])); -typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); -typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData, - int flags)); -typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr, - ClientData clientData)); -typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData, - int flags)); -typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData)); -typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask)); -typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData)); -typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr)); -typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData)); -typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp)); -typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); -typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); -typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, - Tcl_Channel chan, char *address, int port)); -typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData)); -typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *part1, char *part2, int flags)); - -/* - * The structure returned by Tcl_GetCmdInfo and passed into - * Tcl_SetCmdInfo: - */ - -typedef struct Tcl_CmdInfo { - Tcl_CmdProc *proc; /* Procedure to implement command. */ - ClientData clientData; /* ClientData passed to proc. */ - Tcl_CmdDeleteProc *deleteProc; /* Procedure to call when command - * is deleted. */ - ClientData deleteData; /* Value to pass to deleteProc (usually - * the same as clientData). */ -} Tcl_CmdInfo; - -/* - * The structure defined below is used to hold dynamic strings. The only - * field that clients should use is the string field, and they should - * never modify it. - */ - -#define TCL_DSTRING_STATIC_SIZE 200 -typedef struct Tcl_DString { - char *string; /* Points to beginning of string: either - * staticSpace below or a malloc'ed array. */ - int length; /* Number of non-NULL characters in the - * string. */ - int spaceAvl; /* Total number of bytes available for the - * string and its terminating NULL char. */ - char staticSpace[TCL_DSTRING_STATIC_SIZE]; - /* Space to use in common case where string - * is small. */ -} Tcl_DString; - -#define Tcl_DStringLength(dsPtr) ((dsPtr)->length) -#define Tcl_DStringValue(dsPtr) ((dsPtr)->string) -#define Tcl_DStringTrunc Tcl_DStringSetLength - -/* - * Definitions for the maximum number of digits of precision that may - * be specified in the "tcl_precision" variable, and the number of - * characters of buffer space required by Tcl_PrintDouble. - */ - -#define TCL_MAX_PREC 17 -#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) - -/* - * Flag that may be passed to Tcl_ConvertElement to force it not to - * output braces (careful! if you change this flag be sure to change - * the definitions at the front of tclUtil.c). - */ - -#define TCL_DONT_USE_BRACES 1 - -/* - * Flag values passed to Tcl_RecordAndEval. - * WARNING: these bit choices must not conflict with the bit choices - * for evalFlag bits in tclInt.h!! - */ - -#define TCL_NO_EVAL 0x10000 -#define TCL_EVAL_GLOBAL 0x20000 - -/* - * Special freeProc values that may be passed to Tcl_SetResult (see - * the man page for details): - */ - -#define TCL_VOLATILE ((Tcl_FreeProc *) 1) -#define TCL_STATIC ((Tcl_FreeProc *) 0) -#define TCL_DYNAMIC ((Tcl_FreeProc *) 3) - -/* - * Flag values passed to variable-related procedures. - */ - -#define TCL_GLOBAL_ONLY 1 -#define TCL_APPEND_VALUE 2 -#define TCL_LIST_ELEMENT 4 -#define TCL_TRACE_READS 0x10 -#define TCL_TRACE_WRITES 0x20 -#define TCL_TRACE_UNSETS 0x40 -#define TCL_TRACE_DESTROYED 0x80 -#define TCL_INTERP_DESTROYED 0x100 -#define TCL_LEAVE_ERR_MSG 0x200 - -/* - * Types for linked variables: - */ - -#define TCL_LINK_INT 1 -#define TCL_LINK_DOUBLE 2 -#define TCL_LINK_BOOLEAN 3 -#define TCL_LINK_STRING 4 -#define TCL_LINK_READ_ONLY 0x80 - -/* - * The following declarations either map ckalloc and ckfree to - * malloc and free, or they map them to procedures with all sorts - * of debugging hooks defined in tclCkalloc.c. - */ - -#ifdef TCL_MEM_DEBUG - -# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) -# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) -# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) - -EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); -EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, - int line)); - -#else - -# define ckalloc(x) malloc(x) -# define ckfree(x) free(x) -# define ckrealloc(x,y) realloc(x,y) - -# define Tcl_DumpActiveMemory(x) -# define Tcl_ValidateAllMemory(x,y) - -#endif /* TCL_MEM_DEBUG */ - -/* - * Macro to free result of interpreter. - */ - -#define Tcl_FreeResult(interp) \ - if ((interp)->freeProc != 0) { \ - if (((interp)->freeProc == TCL_DYNAMIC) \ - || ((interp)->freeProc == (Tcl_FreeProc *) free)) { \ - ckfree((interp)->result); \ - } else { \ - (*(interp)->freeProc)((interp)->result); \ - } \ - (interp)->freeProc = 0; \ - } - -/* - * Forward declaration of Tcl_HashTable. Needed by some C++ compilers - * to prevent errors when the forward reference to Tcl_HashTable is - * encountered in the Tcl_HashEntry structure. - */ - -#ifdef __cplusplus -struct Tcl_HashTable; -#endif - -/* - * Structure definition for an entry in a hash table. No-one outside - * Tcl should access any of these fields directly; use the macros - * defined below. - */ - -typedef struct Tcl_HashEntry { - struct Tcl_HashEntry *nextPtr; /* Pointer to next entry in this - * hash bucket, or NULL for end of - * chain. */ - struct Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ - struct Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to - * first entry in this entry's chain: - * used for deleting the entry. */ - ClientData clientData; /* Application stores something here - * with Tcl_SetHashValue. */ - union { /* Key has one of these forms: */ - char *oneWordValue; /* One-word value for key. */ - int words[1]; /* Multiple integer words for key. - * The actual size will be as large - * as necessary for this table's - * keys. */ - char string[4]; /* String for key. The actual size - * will be as large as needed to hold - * the key. */ - } key; /* MUST BE LAST FIELD IN RECORD!! */ -} Tcl_HashEntry; - -/* - * Structure definition for a hash table. Must be in tcl.h so clients - * can allocate space for these structures, but clients should never - * access any fields in this structure. - */ - -#define TCL_SMALL_HASH_TABLE 4 -typedef struct Tcl_HashTable { - Tcl_HashEntry **buckets; /* Pointer to bucket array. Each - * element points to first entry in - * bucket's hash chain, or NULL. */ - Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; - /* Bucket array used for small tables - * (to avoid mallocs and frees). */ - int numBuckets; /* Total number of buckets allocated - * at **bucketPtr. */ - int numEntries; /* Total number of entries present - * in table. */ - int rebuildSize; /* Enlarge table when numEntries gets - * to be this large. */ - int downShift; /* Shift count used in hashing - * function. Designed to use high- - * order bits of randomized keys. */ - int mask; /* Mask value used in hashing - * function. */ - int keyType; /* Type of keys used in this table. - * It's either TCL_STRING_KEYS, - * TCL_ONE_WORD_KEYS, or an integer - * giving the number of ints that - * is the size of the key. - */ - Tcl_HashEntry *(*findProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, - char *key)); - Tcl_HashEntry *(*createProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, - char *key, int *newPtr)); -} Tcl_HashTable; - -/* - * Structure definition for information used to keep track of searches - * through hash tables: - */ - -typedef struct Tcl_HashSearch { - Tcl_HashTable *tablePtr; /* Table being searched. */ - int nextIndex; /* Index of next bucket to be - * enumerated after present one. */ - Tcl_HashEntry *nextEntryPtr; /* Next entry to be enumerated in the - * the current bucket. */ -} Tcl_HashSearch; - -/* - * Acceptable key types for hash tables: - */ - -#define TCL_STRING_KEYS 0 -#define TCL_ONE_WORD_KEYS 1 - -/* - * Macros for clients to use to access fields of hash entries: - */ - -#define Tcl_GetHashValue(h) ((h)->clientData) -#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value)) -#define Tcl_GetHashKey(tablePtr, h) \ - ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) ? (h)->key.oneWordValue \ - : (h)->key.string)) - -/* - * Macros to use for clients to use to invoke find and create procedures - * for hash tables: - */ - -#define Tcl_FindHashEntry(tablePtr, key) \ - (*((tablePtr)->findProc))(tablePtr, key) -#define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ - (*((tablePtr)->createProc))(tablePtr, key, newPtr) - -/* - * Flag values to pass to Tcl_DoOneEvent to disable searches - * for some kinds of events: - */ - -#define TCL_DONT_WAIT (1<<1) -#define TCL_WINDOW_EVENTS (1<<2) -#define TCL_FILE_EVENTS (1<<3) -#define TCL_TIMER_EVENTS (1<<4) -#define TCL_IDLE_EVENTS (1<<5) /* WAS 0x10 ???? */ -#define TCL_ALL_EVENTS (~TCL_DONT_WAIT) - -/* - * The following structure defines a generic event for the Tcl event - * system. These are the things that are queued in calls to Tcl_QueueEvent - * and serviced later by Tcl_DoOneEvent. There can be many different - * kinds of events with different fields, corresponding to window events, - * timer events, etc. The structure for a particular event consists of - * a Tcl_Event header followed by additional information specific to that - * event. - */ - -struct Tcl_Event { - Tcl_EventProc *proc; /* Procedure to call to service this event. */ - struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */ -}; - -/* - * Positions to pass to Tk_QueueEvent: - */ - -typedef enum { - TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK -} Tcl_QueuePosition; - -/* - * The following structure keeps is used to hold a time value, either as - * an absolute time (the number of seconds from the epoch) or as an - * elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT. - * On Macintosh systems the epoch is Midnight Jan 1, 1904 GMT. - */ - -typedef struct Tcl_Time { - long sec; /* Seconds. */ - long usec; /* Microseconds. */ -} Tcl_Time; - -/* - * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler - * to indicate what sorts of events are of interest: - */ - -#define TCL_READABLE (1<<1) -#define TCL_WRITABLE (1<<2) -#define TCL_EXCEPTION (1<<3) - -/* - * Flag values to pass to Tcl_OpenCommandChannel to indicate the - * disposition of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR, - * are also used in Tcl_GetStdChannel. - */ - -#define TCL_STDIN (1<<1) -#define TCL_STDOUT (1<<2) -#define TCL_STDERR (1<<3) -#define TCL_ENFORCE_MODE (1<<4) - -/* - * Typedefs for the various operations in a channel type: - */ - -typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_((ClientData instanceData, - Tcl_File inFile, Tcl_File outFile, int mode)); -typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, Tcl_File inFile, Tcl_File outFile)); -typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData, - Tcl_File inFile, char *buf, int toRead, - int *errorCodePtr)); -typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData, - Tcl_File outFile, char *buf, int toWrite, - int *errorCodePtr)); -typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData, - Tcl_File inFile, Tcl_File outFile, long offset, int mode, - int *errorCodePtr)); -typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_(( - ClientData instanceData, Tcl_Interp *interp, - char *optionName, char *value)); -typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_(( - ClientData instanceData, char *optionName, - Tcl_DString *dsPtr)); - -/* - * Enum for different end of line translation and recognition modes. - */ - -typedef enum Tcl_EolTranslation { - TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */ - TCL_TRANSLATE_CR, /* Eol == \r. */ - TCL_TRANSLATE_LF, /* Eol == \n. */ - TCL_TRANSLATE_CRLF /* Eol == \r\n. */ -} Tcl_EolTranslation; - -/* - * struct Tcl_ChannelType: - * - * One such structure exists for each type (kind) of channel. - * It collects together in one place all the functions that are - * part of the specific channel type. - */ - -typedef struct Tcl_ChannelType { - char *typeName; /* The name of the channel type in Tcl - * commands. This storage is owned by - * channel type. */ - Tcl_DriverBlockModeProc *blockModeProc; - /* Set blocking mode for the - * raw channel. May be NULL. */ - Tcl_DriverCloseProc *closeProc; /* Procedure to call to close - * the channel. */ - Tcl_DriverInputProc *inputProc; /* Procedure to call for input - * on channel. */ - Tcl_DriverOutputProc *outputProc; /* Procedure to call for output - * on channel. */ - Tcl_DriverSeekProc *seekProc; /* Procedure to call to seek - * on the channel. May be NULL. */ - Tcl_DriverSetOptionProc *setOptionProc; - /* Set an option on a channel. */ - Tcl_DriverGetOptionProc *getOptionProc; - /* Get an option from a channel. */ -} Tcl_ChannelType; - -/* - * The following flags determine whether the blockModeProc above should - * set the channel into blocking or nonblocking mode. They are passed - * as arguments to the blockModeProc procedure in the above structure. - */ - -#define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */ -#define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking - * mode. */ - -/* - * Types for file handles: - */ - -#define TCL_UNIX_FD 1 -#define TCL_MAC_FILE 2 -#define TCL_MAC_SOCKET 3 -#define TCL_WIN_PIPE 4 -#define TCL_WIN_FILE 5 -#define TCL_WIN_SOCKET 6 -#define TCL_WIN_CONSOLE 7 - -/* - * Enum for different types of file paths. - */ - -typedef enum Tcl_PathType { - TCL_PATH_ABSOLUTE, - TCL_PATH_RELATIVE, - TCL_PATH_VOLUME_RELATIVE -} Tcl_PathType; - -/* - * The following interface is exported for backwards compatibility, but - * is only implemented on Unix. Portable applications should use - * Tcl_OpenCommandChannel, instead. - */ - -EXTERN int Tcl_CreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, pid_t **pidArrayPtr, - int *inPipePtr, int *outPipePtr, - int *errFilePtr)); - -/* - * Exported Tcl procedures: - */ - -EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, - char *message)); -EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp *interp, - char *string)); -EXTERN void Tcl_AppendResult _ANSI_ARGS_( - TCL_VARARGS(Tcl_Interp *,interp)); -EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc *proc, - ClientData clientData)); -EXTERN void Tcl_AsyncDelete _ANSI_ARGS_((Tcl_AsyncHandler async)); -EXTERN int Tcl_AsyncInvoke _ANSI_ARGS_((Tcl_Interp *interp, - int code)); -EXTERN void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async)); -EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void)); -EXTERN void Tcl_BackgroundError _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN char Tcl_Backslash _ANSI_ARGS_((char *src, - int *readPtr)); -EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_InterpDeleteProc *proc, - ClientData clientData)); -EXTERN void Tcl_CancelIdleCall _ANSI_ARGS_((Tcl_IdleProc *idleProc, - ClientData clientData)); -EXTERN VOID * Tcl_Ckalloc _ANSI_ARGS_((unsigned int size)); -EXTERN void Tcl_Ckfree _ANSI_ARGS_((char *ptr)); -EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Channel chan)); -EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char *cmd)); -EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char **argv)); -EXTERN int Tcl_ConvertElement _ANSI_ARGS_((char *src, - char *dst, int flags)); -EXTERN int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp *slave, - char *slaveCmd, Tcl_Interp *target, - char *targetCmd, int argc, char **argv)); -EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_(( - Tcl_ChannelType *typePtr, char *chanName, - Tcl_File inFile, Tcl_File outFile, - ClientData instanceData)); -EXTERN void Tcl_CreateChannelHandler _ANSI_ARGS_(( - Tcl_Channel chan, int mask, - Tcl_ChannelProc *proc, ClientData clientData)); -EXTERN void Tcl_CreateCloseHandler _ANSI_ARGS_(( - Tcl_Channel chan, Tcl_CloseProc *proc, - ClientData clientData)); -EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp *interp, - char *cmdName, Tcl_CmdProc *proc, - ClientData clientData, - Tcl_CmdDeleteProc *deleteProc)); -EXTERN void Tcl_CreateEventSource _ANSI_ARGS_(( - Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc - *checkProc, ClientData clientData)); -EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc, - ClientData clientData)); -EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_(( - Tcl_File file, int mask, Tcl_FileProc *proc, - ClientData clientData)); -EXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void)); -EXTERN void Tcl_CreateMathFunc _ANSI_ARGS_((Tcl_Interp *interp, - char *name, int numArgs, Tcl_ValueType *argTypes, - Tcl_MathProc *proc, ClientData clientData)); -EXTERN void Tcl_CreateModalTimeout _ANSI_ARGS_((int milliseconds, - Tcl_TimerProc *proc, ClientData clientData)); -EXTERN Tcl_Interp *Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, - char *slaveName, int isSafe)); -EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds, - Tcl_TimerProc *proc, ClientData clientData)); -EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp *interp, - int level, Tcl_CmdTraceProc *proc, - ClientData clientData)); -EXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size, - char *file, int line)); -EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char *ptr, - char *file, int line)); -EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char *ptr, - unsigned int size, char *file, int line)); -EXTERN void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp *interp, - char *name)); -EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp *interp, - char *cmdName)); -EXTERN void Tcl_DeleteChannelHandler _ANSI_ARGS_(( - Tcl_Channel chan, Tcl_ChannelProc *proc, - ClientData clientData)); -EXTERN void Tcl_DeleteCloseHandler _ANSI_ARGS_(( - Tcl_Channel chan, Tcl_CloseProc *proc, - ClientData clientData)); -EXTERN void Tcl_DeleteEventSource _ANSI_ARGS_(( - Tcl_EventSetupProc *setupProc, - Tcl_EventCheckProc *checkProc, - ClientData clientData)); -EXTERN void Tcl_DeleteEvents _ANSI_ARGS_(( - Tcl_EventDeleteProc *proc, - ClientData clientData)); -EXTERN void Tcl_DeleteExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc, - ClientData clientData)); -EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_(( - Tcl_File file)); -EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_(( - Tcl_HashEntry *entryPtr)); -EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_(( - Tcl_HashTable *tablePtr)); -EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN void Tcl_DeleteModalTimeout _ANSI_ARGS_(( - Tcl_TimerProc *proc, ClientData clientData)); -EXTERN void Tcl_DeleteTimerHandler _ANSI_ARGS_(( - Tcl_TimerToken token)); -EXTERN void Tcl_DeleteTrace _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Trace trace)); -EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, pid_t *pidPtr)); -EXTERN void Tcl_DontCallWhenDeleted _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, - ClientData clientData)); -EXTERN int Tcl_DoOneEvent _ANSI_ARGS_((int flags)); -EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc *proc, - ClientData clientData)); -EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString *dsPtr, - char *string, int length)); -EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_(( - Tcl_DString *dsPtr, char *string)); -EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_((Tcl_DString *dsPtr)); -EXTERN void Tcl_DStringFree _ANSI_ARGS_((Tcl_DString *dsPtr)); -EXTERN void Tcl_DStringGetResult _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_DString *dsPtr)); -EXTERN void Tcl_DStringInit _ANSI_ARGS_((Tcl_DString *dsPtr)); -EXTERN void Tcl_DStringResult _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_DString *dsPtr)); -EXTERN void Tcl_DStringSetLength _ANSI_ARGS_((Tcl_DString *dsPtr, - int length)); -EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_(( - Tcl_DString *dsPtr)); -EXTERN int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan)); -EXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void)); -EXTERN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err)); -EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp, char *cmd)); -EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp, - char *fileName)); -EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((ClientData clientData, - Tcl_FreeProc *freeProc)); -EXTERN void Tcl_Exit _ANSI_ARGS_((int status)); -EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int *ptr)); -EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp *interp, - char *string, double *ptr)); -EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp *interp, - char *string, long *ptr)); -EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp *interp, - char *string)); -EXTERN int Tcl_FileReady _ANSI_ARGS_((Tcl_File file, - int mask)); -EXTERN void Tcl_FindExecutable _ANSI_ARGS_((char *argv0)); -EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_(( - Tcl_HashTable *tablePtr, - Tcl_HashSearch *searchPtr)); -EXTERN int Tcl_Flush _ANSI_ARGS_((Tcl_Channel chan)); -EXTERN void Tcl_FreeFile _ANSI_ARGS_(( - Tcl_File file)); -EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp *interp, - char *slaveCmd, Tcl_Interp **targetInterpPtr, - char **targetCmdPtr, int *argcPtr, - char ***argvPtr)); -EXTERN ClientData Tcl_GetAssocData _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_InterpDeleteProc **procPtr)); -EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int *boolPtr)); -EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp *interp, - char *chanName, int *modePtr)); -EXTERN int Tcl_GetChannelBufferSize _ANSI_ARGS_(( - Tcl_Channel chan)); -EXTERN Tcl_File Tcl_GetChannelFile _ANSI_ARGS_((Tcl_Channel chan, - int direction)); -EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_(( - Tcl_Channel chan)); -EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((Tcl_Channel chan, - char *optionName, Tcl_DString *dsPtr)); -EXTERN char * Tcl_GetChannelName _ANSI_ARGS_((Tcl_Channel chan)); -EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan)); -EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, - char *cmdName, Tcl_CmdInfo *infoPtr)); -EXTERN char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Command command)); -EXTERN char * Tcl_GetCwd _ANSI_ARGS_((char *buf, int len)); -EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp, - char *string, double *doublePtr)); -EXTERN int Tcl_GetErrno _ANSI_ARGS_((void)); -EXTERN Tcl_File Tcl_GetFile _ANSI_ARGS_((ClientData fileData, - int type)); -EXTERN ClientData Tcl_GetFileInfo _ANSI_ARGS_((Tcl_File file, - int *typePtr)); -EXTERN char * Tcl_GetHostName _ANSI_ARGS_((void)); -EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int *intPtr)); -EXTERN int Tcl_GetInterpPath _ANSI_ARGS_((Tcl_Interp *askInterp, - Tcl_Interp *slaveInterp)); -EXTERN Tcl_Interp *Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN ClientData Tcl_GetNotifierData _ANSI_ARGS_((Tcl_File file, - Tcl_FileFreeProc **freeProcPtr)); -EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int write, int checkUsage, - ClientData *filePtr)); -EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((char *path)); -EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan, - Tcl_DString *dsPtr)); -EXTERN Tcl_Interp *Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp *interp, - char *slaveName)); -EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type)); -EXTERN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp *interp, - char *varName, int flags)); -EXTERN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, int flags)); -EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp *interp, - char *command)); -EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr)); -EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr, - int keyType)); -EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int Tcl_InputBlocked _ANSI_ARGS_((Tcl_Channel chan)); -EXTERN int Tcl_InputBuffered _ANSI_ARGS_((Tcl_Channel chan)); -EXTERN int Tcl_InterpDeleted _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, char **argv, - Tcl_DString *resultPtr)); -EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp *interp, - char *varName, char *addr, int type)); -EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, - Tcl_AppInitProc *appInitProc)); -EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData inFile, - ClientData outFile, int mode)); -EXTERN int Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN Tcl_Channel Tcl_MakeTcpClientChannel _ANSI_ARGS_(( - ClientData tcpSocket)); -EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char **argv)); -EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_(( - Tcl_HashSearch *searchPtr)); -EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_(( - Tcl_Interp *interp, int argc, char **argv, - int flags)); -EXTERN Tcl_Channel Tcl_OpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, - char *fileName, char *modeString, - int permissions)); -EXTERN Tcl_Channel Tcl_OpenTcpClient _ANSI_ARGS_((Tcl_Interp *interp, - int port, char *address, char *myaddr, - int myport, int async)); -EXTERN Tcl_Channel Tcl_OpenTcpServer _ANSI_ARGS_((Tcl_Interp *interp, - int port, char *host, - Tcl_TcpAcceptProc *acceptProc, - ClientData callbackData)); -EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char **termPtr)); -EXTERN int Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp *interp, - char *name, char *version)); -EXTERN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp *interp, - char *name, char *version, int exact)); -EXTERN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN void Tcl_Preserve _ANSI_ARGS_((ClientData data)); -EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp *interp, - double value, char *dst)); -EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char *string)); -EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event *evPtr, - Tcl_QueuePosition position)); -EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan, - char *bufPtr, int toRead)); -EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void)); -EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp, - char *cmd, int flags)); -EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp *interp, - char *string)); -EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_RegExp regexp, char *string, char *start)); -EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *pattern)); -EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, - int index, char **startPtr, char **endPtr)); -EXTERN void Tcl_RegisterChannel _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Channel chan)); -EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData)); -EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp)); -#define Tcl_Return Tcl_SetResult -EXTERN int Tcl_ScanElement _ANSI_ARGS_((char *string, - int *flagPtr)); -EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, - int offset, int mode)); -EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_InterpDeleteProc *proc, - ClientData clientData)); -EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_(( - Tcl_Channel chan, int sz)); -EXTERN int Tcl_SetChannelOption _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Channel chan, - char *optionName, char *newValue)); -EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, - char *cmdName, Tcl_CmdInfo *infoPtr)); -EXTERN void Tcl_SetErrno _ANSI_ARGS_((int errno)); -EXTERN void Tcl_SetErrorCode _ANSI_ARGS_( - TCL_VARARGS(Tcl_Interp *,interp)); -EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time *timePtr)); -EXTERN void Tcl_SetNotifierData _ANSI_ARGS_((Tcl_File file, - Tcl_FileFreeProc *freeProcPtr, ClientData data)); -EXTERN void Tcl_SetPanicProc _ANSI_ARGS_((void (*proc) - _ANSI_ARGS_(TCL_VARARGS(char *, format)))); -EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp, - int depth)); -EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp *interp, - char *string, Tcl_FreeProc *freeProc)); -EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel, - int type)); -EXTERN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp *interp, - char *varName, char *newValue, int flags)); -EXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, char *newValue, - int flags)); -EXTERN char * Tcl_SignalId _ANSI_ARGS_((int sig)); -EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); -EXTERN void Tcl_Sleep _ANSI_ARGS_((int ms)); -EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp *interp, - char *list, int *argcPtr, char ***argvPtr)); -EXTERN void Tcl_SplitPath _ANSI_ARGS_((char *path, - int *argcPtr, char ***argvPtr)); -EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp *interp, - char *pkgName, Tcl_PackageInitProc *initProc, - Tcl_PackageInitProc *safeInitProc)); -EXTERN int Tcl_StringMatch _ANSI_ARGS_((char *string, - char *pattern)); -EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan)); -#define Tcl_TildeSubst Tcl_TranslateFileName -EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp *interp, - char *varName, int flags, Tcl_VarTraceProc *proc, - ClientData clientData)); -EXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, int flags, - Tcl_VarTraceProc *proc, ClientData clientData)); -EXTERN char * Tcl_TranslateFileName _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_DString *bufferPtr)); -EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp *interp, - char *varName)); -EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Channel chan)); -EXTERN int Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp *interp, - char *varName, int flags)); -EXTERN int Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, int flags)); -EXTERN void Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp *interp, - char *varName, int flags, Tcl_VarTraceProc *proc, - ClientData clientData)); -EXTERN void Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, int flags, - Tcl_VarTraceProc *proc, ClientData clientData)); -EXTERN void Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp *interp, - char *varName)); -EXTERN int Tcl_UpVar _ANSI_ARGS_((Tcl_Interp *interp, - char *frameName, char *varName, - char *localName, int flags)); -EXTERN int Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp *interp, - char *frameName, char *part1, char *part2, - char *localName, int flags)); -EXTERN int Tcl_VarEval _ANSI_ARGS_( - TCL_VARARGS(Tcl_Interp *,interp)); -EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp *interp, - char *varName, int flags, - Tcl_VarTraceProc *procPtr, - ClientData prevClientData)); -EXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, int flags, - Tcl_VarTraceProc *procPtr, - ClientData prevClientData)); -EXTERN int Tcl_WaitForEvent _ANSI_ARGS_((Tcl_Time *timePtr)); -EXTERN int Tcl_WaitPid _ANSI_ARGS_((pid_t pid, int *statPtr, - int options)); -EXTERN void Tcl_WatchFile _ANSI_ARGS_((Tcl_File file, - int mask)); -EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, - char *s, int slen)); - -/* JET 8/2018 - * - * dtdocbook/instant has been modified to use a more modern Tcl (8.6), - * which means certain functions are not present when we are using the - * dtdocbook/tcl (7.5) version of tcl instead of a modern system - * version. So, create some defines that should work around this - * problem. - */ - -#define Tcl_Alloc(n) malloc(n) -#define Tcl_Free(p) free(p) - -#define Tcl_GetStringResult(i) ((i)->result) -#define Tcl_GetErrorLine(i) ((i)->errorLine) - -#endif /* _TCL */ diff --git a/cde/programs/dtdocbook/tcl/tclAsync.c b/cde/programs/dtdocbook/tcl/tclAsync.c deleted file mode 100644 index 0dc6c0fa..00000000 --- a/cde/programs/dtdocbook/tcl/tclAsync.c +++ /dev/null @@ -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; -} diff --git a/cde/programs/dtdocbook/tcl/tclBasic.c b/cde/programs/dtdocbook/tcl/tclBasic.c deleted file mode 100644 index ba16ba1f..00000000 --- a/cde/programs/dtdocbook/tcl/tclBasic.c +++ /dev/null @@ -1,1864 +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: tclBasic.c /main/5 1998/04/17 11:24:16 mgreess $ */ -/* - * tclBasic.c -- - * - * Contains the basic facilities for TCL command interpretation, - * including interpreter creation and deletion, command creation - * and deletion, and command parsing and execution. - * - * Copyright (c) 1987-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: @(#) tclBasic.c 1.210 96/03/25 17:17:54 - */ - -#include "tclInt.h" -#ifndef TCL_GENERIC_ONLY -# include "tclPort.h" -#endif -#include "patchlevel.h" - -/* - * Static procedures in this file: - */ - -static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); - -/* - * The following structure defines all of the commands in the Tcl core, - * and the C procedures that execute them. - */ - -typedef struct { - char *name; /* Name of command. */ - Tcl_CmdProc *proc; /* Procedure that executes command. */ -} CmdInfo; - -/* - * Built-in commands, and the procedures associated with them: - */ - -static CmdInfo builtInCmds[] = { - /* - * Commands in the generic core: - */ - - {"append", Tcl_AppendCmd}, - {"array", Tcl_ArrayCmd}, - {"break", Tcl_BreakCmd}, - {"case", Tcl_CaseCmd}, - {"catch", Tcl_CatchCmd}, - {"clock", Tcl_ClockCmd}, - {"concat", Tcl_ConcatCmd}, - {"continue", Tcl_ContinueCmd}, - {"error", Tcl_ErrorCmd}, - {"eval", Tcl_EvalCmd}, - {"exit", Tcl_ExitCmd}, - {"expr", Tcl_ExprCmd}, - {"fileevent", Tcl_FileEventCmd}, - {"for", Tcl_ForCmd}, - {"foreach", Tcl_ForeachCmd}, - {"format", Tcl_FormatCmd}, - {"global", Tcl_GlobalCmd}, - {"history", Tcl_HistoryCmd}, - {"if", Tcl_IfCmd}, - {"incr", Tcl_IncrCmd}, - {"info", Tcl_InfoCmd}, - {"interp", Tcl_InterpCmd}, - {"join", Tcl_JoinCmd}, - {"lappend", Tcl_LappendCmd}, - {"lindex", Tcl_LindexCmd}, - {"linsert", Tcl_LinsertCmd}, - {"list", Tcl_ListCmd}, - {"llength", Tcl_LlengthCmd}, - {"load", Tcl_LoadCmd}, - {"lrange", Tcl_LrangeCmd}, - {"lreplace", Tcl_LreplaceCmd}, - {"lsearch", Tcl_LsearchCmd}, - {"lsort", Tcl_LsortCmd}, - {"package", Tcl_PackageCmd}, - {"proc", Tcl_ProcCmd}, - {"regexp", Tcl_RegexpCmd}, - {"regsub", Tcl_RegsubCmd}, - {"rename", Tcl_RenameCmd}, - {"return", Tcl_ReturnCmd}, - {"scan", Tcl_ScanCmd}, - {"set", Tcl_SetCmd}, - {"split", Tcl_SplitCmd}, - {"string", Tcl_StringCmd}, - {"subst", Tcl_SubstCmd}, - {"switch", Tcl_SwitchCmd}, - {"trace", Tcl_TraceCmd}, - {"unset", Tcl_UnsetCmd}, - {"uplevel", Tcl_UplevelCmd}, - {"upvar", Tcl_UpvarCmd}, - {"while", Tcl_WhileCmd}, - - /* - * Commands in the UNIX core: - */ - -#ifndef TCL_GENERIC_ONLY - {"after", Tcl_AfterCmd}, - {"cd", Tcl_CdCmd}, - {"close", Tcl_CloseCmd}, - {"eof", Tcl_EofCmd}, - {"fblocked", Tcl_FblockedCmd}, - {"fconfigure", Tcl_FconfigureCmd}, - {"file", Tcl_FileCmd}, - {"flush", Tcl_FlushCmd}, - {"gets", Tcl_GetsCmd}, - {"glob", Tcl_GlobCmd}, - {"open", Tcl_OpenCmd}, - {"pid", Tcl_PidCmd}, - {"puts", Tcl_PutsCmd}, - {"pwd", Tcl_PwdCmd}, - {"read", Tcl_ReadCmd}, - {"seek", Tcl_SeekCmd}, - {"socket", Tcl_SocketCmd}, - {"tell", Tcl_TellCmd}, - {"time", Tcl_TimeCmd}, - {"update", Tcl_UpdateCmd}, - {"vwait", Tcl_VwaitCmd}, - {"unsupported0", TclUnsupported0Cmd}, - -#ifndef MAC_TCL - {"exec", Tcl_ExecCmd}, - {"source", Tcl_SourceCmd}, -#endif - -#ifdef MAC_TCL - {"beep", Tcl_MacBeepCmd}, - {"cp", Tcl_CpCmd}, - {"echo", Tcl_EchoCmd}, - {"ls", Tcl_LsCmd}, - {"mkdir", Tcl_MkdirCmd}, - {"mv", Tcl_MvCmd}, - {"rm", Tcl_RmCmd}, - {"rmdir", Tcl_RmdirCmd}, - {"source", Tcl_MacSourceCmd}, -#endif /* MAC_TCL */ - -#endif /* TCL_GENERIC_ONLY */ - {NULL, (Tcl_CmdProc *) NULL} -}; - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateInterp -- - * - * Create a new TCL command interpreter. - * - * Results: - * The return value is a token for the interpreter, which may be - * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or - * Tcl_DeleteInterp. - * - * Side effects: - * The command interpreter is initialized with an empty variable - * table and the built-in commands. - * - *---------------------------------------------------------------------- - */ - -Tcl_Interp * -Tcl_CreateInterp(void) -{ - Interp *iPtr; - Command *cmdPtr; - CmdInfo *cmdInfoPtr; - Tcl_Channel chan; - int i; - - iPtr = (Interp *) ckalloc(sizeof(Interp)); - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - iPtr->errorLine = 0; - Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS); - Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); - Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS); - iPtr->numLevels = 0; - iPtr->maxNestingDepth = 1000; - iPtr->framePtr = NULL; - iPtr->varFramePtr = NULL; - iPtr->activeTracePtr = NULL; - iPtr->returnCode = TCL_OK; - iPtr->errorInfo = NULL; - iPtr->errorCode = NULL; - iPtr->numEvents = 0; - iPtr->events = NULL; - iPtr->curEvent = 0; - iPtr->curEventNum = 0; - iPtr->revPtr = NULL; - iPtr->historyFirst = NULL; - iPtr->revDisables = 1; - iPtr->evalFirst = iPtr->evalLast = NULL; - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - iPtr->appendUsed = 0; - for (i = 0; i < NUM_REGEXPS; i++) { - iPtr->patterns[i] = NULL; - iPtr->patLengths[i] = -1; - iPtr->regexps[i] = NULL; - } - Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); - iPtr->packageUnknown = NULL; - strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); - iPtr->pdPrec = DEFAULT_PD_PREC; - iPtr->cmdCount = 0; - iPtr->noEval = 0; - iPtr->evalFlags = 0; - iPtr->scriptFile = NULL; - iPtr->flags = 0; - iPtr->tracePtr = NULL; - iPtr->assocData = (Tcl_HashTable *) NULL; - iPtr->resultSpace[0] = 0; - - /* - * Create the built-in commands. Do it here, rather than calling - * Tcl_CreateCommand, because it's faster (there's no need to - * check for a pre-existing command by the same name). - */ - - for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { - int new; - Tcl_HashEntry *hPtr; - - hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, - cmdInfoPtr->name, &new); - if (new) { - cmdPtr = (Command *) ckalloc(sizeof(Command)); - cmdPtr->hPtr = hPtr; - cmdPtr->proc = cmdInfoPtr->proc; - cmdPtr->clientData = (ClientData) NULL; - cmdPtr->deleteProc = NULL; - cmdPtr->deleteData = (ClientData) NULL; - cmdPtr->deleted = 0; - Tcl_SetHashValue(hPtr, cmdPtr); - } - } - -#ifndef TCL_GENERIC_ONLY - TclSetupEnv((Tcl_Interp *) iPtr); -#endif - - /* - * Do Safe-Tcl init stuff - */ - - (void) TclInterpInit((Tcl_Interp *)iPtr); - - /* - * Set up variables such as tcl_library and tcl_precision. - */ - - TclPlatformInit((Tcl_Interp *)iPtr); - Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL, - TCL_GLOBAL_ONLY); - Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION, - TCL_GLOBAL_ONLY); - Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - TclPrecTraceProc, (ClientData) NULL); - - /* - * Register Tcl's version number. - */ - - Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION); - - /* - * Add the standard channels. - */ - - chan = Tcl_GetStdChannel(TCL_STDIN); - if (chan != (Tcl_Channel) NULL) { - Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan); - } - chan = Tcl_GetStdChannel(TCL_STDOUT); - if (chan != (Tcl_Channel) NULL) { - Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan); - } - chan = Tcl_GetStdChannel(TCL_STDERR); - if (chan != (Tcl_Channel) NULL) { - Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan); - } - - return (Tcl_Interp *) iPtr; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_CallWhenDeleted -- - * - * Arrange for a procedure to be called before a given - * interpreter is deleted. The procedure is called as soon - * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is - * called on an interpreter that has already been deleted, - * the procedure will be called when the last Tcl_Release is - * done on the interpreter. - * - * Results: - * None. - * - * Side effects: - * When Tcl_DeleteInterp is invoked to delete interp, - * proc will be invoked. See the manual entry for - * details. - * - *-------------------------------------------------------------- - */ -/* interp, Interpreter to watch. */ -/* proc, Procedure to call when interpreter is about to be deleted. */ -/* clientData, One-word value to pass to proc. */ - -void -Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData) -{ - Interp *iPtr = (Interp *) interp; - static int assocDataCounter = 0; - int new; - char buffer[128]; - AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); - Tcl_HashEntry *hPtr; - - sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); - assocDataCounter++; - - if (iPtr->assocData == (Tcl_HashTable *) NULL) { - iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); - } - hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); - dPtr->proc = proc; - dPtr->clientData = clientData; - Tcl_SetHashValue(hPtr, dPtr); -} - -/* - *-------------------------------------------------------------- - * - * Tcl_DontCallWhenDeleted -- - * - * Cancel the arrangement for a procedure to be called when - * a given interpreter is deleted. - * - * Results: - * None. - * - * Side effects: - * If proc and clientData were previously registered as a - * callback via Tcl_CallWhenDeleted, they are unregistered. - * If they weren't previously registered then nothing - * happens. - * - *-------------------------------------------------------------- - */ -/* interp, Interpreter to watch. */ -/* proc, Procedure to call when interpreter is about to be deleted. */ -/* clientData, One-word value to pass to proc. */ - -void -Tcl_DontCallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData) -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashTable *hTablePtr; - Tcl_HashSearch hSearch; - Tcl_HashEntry *hPtr; - AssocData *dPtr; - - hTablePtr = iPtr->assocData; - if (hTablePtr == (Tcl_HashTable *) NULL) { - return; - } - for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); - if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { - ckfree((char *) dPtr); - Tcl_DeleteHashEntry(hPtr); - return; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetAssocData -- - * - * Creates a named association between user-specified data, a delete - * function and this interpreter. If the association already exists - * the data is overwritten with the new data. The delete function will - * be invoked when the interpreter is deleted. - * - * Results: - * None. - * - * Side effects: - * Sets the associated data, creates the association if needed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetAssocData( -Tcl_Interp *interp /* Interpreter to associate with. */, -char *name /* Name for association. */, -Tcl_InterpDeleteProc *proc /* Proc to call when interpreter is about to be deleted. */, -ClientData clientData /* One-word value to pass to proc. */ -) -{ - Interp *iPtr = (Interp *) interp; - AssocData *dPtr; - Tcl_HashEntry *hPtr; - int new; - - if (iPtr->assocData == (Tcl_HashTable *) NULL) { - iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); - } - hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); - if (new == 0) { - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); - } else { - dPtr = (AssocData *) ckalloc(sizeof(AssocData)); - } - dPtr->proc = proc; - dPtr->clientData = clientData; - - Tcl_SetHashValue(hPtr, dPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteAssocData -- - * - * Deletes a named association of user-specified data with - * the specified interpreter. - * - * Results: - * None. - * - * Side effects: - * Deletes the association. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteAssocData( - Tcl_Interp *interp /* Interpreter to associate with. */, - char *name /* Name of association. */ -) -{ - Interp *iPtr = (Interp *) interp; - AssocData *dPtr; - Tcl_HashEntry *hPtr; - - if (iPtr->assocData == (Tcl_HashTable *) NULL) { - return; - } - hPtr = Tcl_FindHashEntry(iPtr->assocData, name); - if (hPtr == (Tcl_HashEntry *) NULL) { - return; - } - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); - if (dPtr->proc != NULL) { - (dPtr->proc) (dPtr->clientData, interp); - } - ckfree((char *) dPtr); - Tcl_DeleteHashEntry(hPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetAssocData -- - * - * Returns the client data associated with this name in the - * specified interpreter. - * - * Results: - * The client data in the AssocData record denoted by the named - * association, or NULL. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_GetAssocData( - Tcl_Interp *interp /* Interpreter associated with. */, - char *name /* Name of association. */, - Tcl_InterpDeleteProc **procPtr /* Pointer to place to store address - * of current deletion callback. */ -) -{ - Interp *iPtr = (Interp *) interp; - AssocData *dPtr; - Tcl_HashEntry *hPtr; - - if (iPtr->assocData == (Tcl_HashTable *) NULL) { - return (ClientData) NULL; - } - hPtr = Tcl_FindHashEntry(iPtr->assocData, name); - if (hPtr == (Tcl_HashEntry *) NULL) { - return (ClientData) NULL; - } - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); - if (procPtr != (Tcl_InterpDeleteProc **) NULL) { - *procPtr = dPtr->proc; - } - return dPtr->clientData; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteInterpProc -- - * - * Helper procedure to delete an interpreter. This procedure is - * called when the last call to Tcl_Preserve on this interpreter - * is matched by a call to Tcl_Release. The procedure cleans up - * all resources used in the interpreter and calls all currently - * registered interpreter deletion callbacks. - * - * Results: - * None. - * - * Side effects: - * Whatever the interpreter deletion callbacks do. Frees resources - * used by the interpreter. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteInterpProc( - Tcl_Interp *interp /* Interpreter to delete. */ -) -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - int i; - Tcl_HashTable *hTablePtr; - AssocData *dPtr; - - /* - * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. - */ - - if (iPtr->numLevels > 0) { - panic("DeleteInterpProc called with active evals"); - } - - /* - * The interpreter should already be marked deleted; otherwise how - * did we get here? - */ - - if (!(iPtr->flags & DELETED)) { - panic("DeleteInterpProc called on interpreter not marked deleted"); - } - - /* - * First delete all the commands. There's a special hack here - * because "tkerror" is just a synonym for "bgerror" (they share - * a Command structure). Just delete the hash table entry for - * "tkerror" without invoking its callback or cleaning up its - * Command structure. - */ - - hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror"); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); - } - for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search)) { - Tcl_DeleteCommand(interp, - Tcl_GetHashKey(&iPtr->commandTable, hPtr)); - } - Tcl_DeleteHashTable(&iPtr->commandTable); - for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - ckfree((char *) Tcl_GetHashValue(hPtr)); - } - Tcl_DeleteHashTable(&iPtr->mathFuncTable); - - /* - * Invoke deletion callbacks; note that a callback can create new - * callbacks, so we iterate. - */ - - while (iPtr->assocData != (Tcl_HashTable *) NULL) { - hTablePtr = iPtr->assocData; - iPtr->assocData = (Tcl_HashTable *) NULL; - for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { - dPtr = (AssocData *) Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); - if (dPtr->proc != NULL) { - (*dPtr->proc)(dPtr->clientData, interp); - } - ckfree((char *) dPtr); - } - Tcl_DeleteHashTable(hTablePtr); - ckfree((char *) hTablePtr); - } - - /* - * Delete all global variables: - */ - - TclDeleteVars(iPtr, &iPtr->globalTable); - - /* - * Free up the result *after* deleting variables, since variable - * deletion could have transferred ownership of the result string - * to Tcl. - */ - - Tcl_FreeResult(interp); - interp->result = NULL; - - if (iPtr->errorInfo != NULL) { - ckfree(iPtr->errorInfo); - iPtr->errorInfo = NULL; - } - if (iPtr->errorCode != NULL) { - ckfree(iPtr->errorCode); - iPtr->errorCode = NULL; - } - if (iPtr->events != NULL) { - int i; - - for (i = 0; i < iPtr->numEvents; i++) { - ckfree(iPtr->events[i].command); - } - ckfree((char *) iPtr->events); - iPtr->events = NULL; - } - while (iPtr->revPtr != NULL) { - HistoryRev *nextPtr = iPtr->revPtr->nextPtr; - - ckfree(iPtr->revPtr->newBytes); - ckfree((char *) iPtr->revPtr); - iPtr->revPtr = nextPtr; - } - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; - } - for (i = 0; i < NUM_REGEXPS; i++) { - if (iPtr->patterns[i] == NULL) { - break; - } - ckfree(iPtr->patterns[i]); - ckfree((char *) iPtr->regexps[i]); - iPtr->regexps[i] = NULL; - } - TclFreePackageInfo(iPtr); - while (iPtr->tracePtr != NULL) { - Trace *nextPtr = iPtr->tracePtr->nextPtr; - - ckfree((char *) iPtr->tracePtr); - iPtr->tracePtr = nextPtr; - } - - ckfree((char *) iPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InterpDeleted -- - * - * Returns nonzero if the interpreter has been deleted with a call - * to Tcl_DeleteInterp. - * - * Results: - * Nonzero if the interpreter is deleted, zero otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_InterpDeleted(Tcl_Interp *interp) -{ - return (((Interp *) interp)->flags & DELETED) ? 1 : 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteInterp -- - * - * Ensures that the interpreter will be deleted eventually. If there - * are no Tcl_Preserve calls in effect for this interpreter, it is - * deleted immediately, otherwise the interpreter is deleted when - * the last Tcl_Preserve is matched by a call to Tcl_Release. In either - * case, the procedure runs the currently registered deletion callbacks. - * - * Results: - * None. - * - * Side effects: - * The interpreter is marked as deleted. The caller may still use it - * safely if there are calls to Tcl_Preserve in effect for the - * interpreter, but further calls to Tcl_Eval etc in this interpreter - * will fail. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteInterp( - Tcl_Interp *interp /* Token for command interpreter (returned - * by a previous call to Tcl_CreateInterp). */ -) -{ - Interp *iPtr = (Interp *) interp; - - /* - * If the interpreter has already been marked deleted, just punt. - */ - - if (iPtr->flags & DELETED) { - return; - } - - /* - * Mark the interpreter as deleted. No further evals will be allowed. - */ - - iPtr->flags |= DELETED; - - /* - * Ensure that the interpreter is eventually deleted. - */ - - Tcl_EventuallyFree((ClientData) interp, - (Tcl_FreeProc *) DeleteInterpProc); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateCommand -- - * - * Define a new command in a command table. - * - * Results: - * The return value is a token for the command, which can - * be used in future calls to Tcl_NameOfCommand. - * - * Side effects: - * If a command named cmdName already exists for interp, it is - * deleted. In the future, when cmdName is seen as the name of - * a command by Tcl_Eval, proc will be called. When the command - * is deleted from the table, deleteProc will be called. See the - * manual entry for details on the calling sequence. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -Tcl_CreateCommand( - Tcl_Interp *interp, /* Token for command interpreter (returned - * by a previous call to Tcl_CreateInterp). */ - char *cmdName, /* Name of command. */ - Tcl_CmdProc *proc, /* Command procedure to associate with - * cmdName. */ - ClientData clientData, /* Arbitrary one-word value to pass to proc. */ - Tcl_CmdDeleteProc *deleteProc - /* If not NULL, gives a procedure to call when - * this command is deleted. */ -) -{ - Interp *iPtr = (Interp *) interp; - Command *cmdPtr; - Tcl_HashEntry *hPtr; - int new; - - /* - * The code below was added in 11/95 to preserve backwards compatibility - * when "tkerror" was renamed "bgerror": if anyone attempts to define - * "tkerror" as a command, it is actually created as "bgerror". This - * code should eventually be removed. - */ - - if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) { - cmdName = "bgerror"; - } - - if (iPtr->flags & DELETED) { - - /* - * The interpreter is being deleted. Don't create any new - * commands; it's not safe to muck with the interpreter anymore. - */ - - return (Tcl_Command) NULL; - } - hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new); - if (!new) { - /* - * Command already exists: delete the old one. - */ - - Tcl_DeleteCommand(interp, Tcl_GetHashKey(&iPtr->commandTable, hPtr)); - hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new); - if (!new) { - /* - * Drat. The stupid deletion callback recreated the command. - * Just throw away the new command (if we try to delete it again, - * we could get stuck in an infinite loop). - */ - - ckfree((char *) Tcl_GetHashValue(hPtr)); - } - } - cmdPtr = (Command *) ckalloc(sizeof(Command)); - Tcl_SetHashValue(hPtr, cmdPtr); - cmdPtr->hPtr = hPtr; - cmdPtr->proc = proc; - cmdPtr->clientData = clientData; - cmdPtr->deleteProc = deleteProc; - cmdPtr->deleteData = clientData; - cmdPtr->deleted = 0; - - /* - * The code below provides more backwards compatibility for the - * renaming of "tkerror" to "bgerror". Like the code above, this - * code should eventually become unnecessary. - */ - - if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) { - /* - * We're currently creating the "bgerror" command; create - * a "tkerror" command that shares the same Command structure. - */ - - hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new); - Tcl_SetHashValue(hPtr, cmdPtr); - } - return (Tcl_Command) cmdPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetCommandInfo -- - * - * Modifies various information about a Tcl command. - * - * Results: - * If cmdName exists in interp, then the information at *infoPtr - * is stored with the command in place of the current information - * and 1 is returned. If the command doesn't exist then 0 is - * returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetCommandInfo( - Tcl_Interp *interp, /* Interpreter in which to look - * for command. */ - char *cmdName, /* Name of desired command. */ - Tcl_CmdInfo *infoPtr /* Where to store information about - * command. */ -) -{ - Tcl_HashEntry *hPtr; - Command *cmdPtr; - - hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName); - if (hPtr == NULL) { - return 0; - } - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - cmdPtr->proc = infoPtr->proc; - cmdPtr->clientData = infoPtr->clientData; - cmdPtr->deleteProc = infoPtr->deleteProc; - cmdPtr->deleteData = infoPtr->deleteData; - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetCommandInfo -- - * - * Returns various information about a Tcl command. - * - * Results: - * If cmdName exists in interp, then *infoPtr is modified to - * hold information about cmdName and 1 is returned. If the - * command doesn't exist then 0 is returned and *infoPtr isn't - * modified. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetCommandInfo( - Tcl_Interp *interp, /* Interpreter in which to look - * for command. */ - char *cmdName, /* Name of desired command. */ - Tcl_CmdInfo *infoPtr /* Where to store information about - * command. */ -) -{ - Tcl_HashEntry *hPtr; - Command *cmdPtr; - - hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName); - if (hPtr == NULL) { - return 0; - } - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - infoPtr->proc = cmdPtr->proc; - infoPtr->clientData = cmdPtr->clientData; - infoPtr->deleteProc = cmdPtr->deleteProc; - infoPtr->deleteData = cmdPtr->deleteData; - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetCommandName -- - * - * Given a token returned by Tcl_CreateCommand, this procedure - * returns the current name of the command (which may have changed - * due to renaming). - * - * Results: - * The return value is the name of the given command. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_GetCommandName( - Tcl_Interp *interp, /* Interpreter containing the command. */ - Tcl_Command command /* Token for the command, returned by a - * previous call to Tcl_CreateCommand. - * The command must not have been deleted. */ -) -{ - Command *cmdPtr = (Command *) command; - Interp *iPtr = (Interp *) interp; - - if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { - - /* - * This should only happen if command was "created" after the - * interpreter began to be deleted, so there isn't really any - * command. Just return an empty string. - */ - - return ""; - } - return Tcl_GetHashKey(&iPtr->commandTable, cmdPtr->hPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteCommand -- - * - * Remove the given command from the given interpreter. - * - * Results: - * 0 is returned if the command was deleted successfully. - * -1 is returned if there didn't exist a command by that - * name. - * - * Side effects: - * CmdName will no longer be recognized as a valid command for - * interp. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_DeleteCommand( - Tcl_Interp *interp, /* Token for command interpreter (returned - * by a previous call to Tcl_CreateInterp). */ - char *cmdName /* Name of command to remove. */ -) -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr, *tkErrorHPtr; - Command *cmdPtr; - - /* - * The code below was added in 11/95 to preserve backwards compatibility - * when "tkerror" was renamed "bgerror": if anyone attempts to delete - * "tkerror", delete both it and "bgerror". This code should - * eventually be removed. - */ - - if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) { - cmdName = "bgerror"; - } - hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName); - if (hPtr == NULL) { - return -1; - } - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - - /* - * The code here is tricky. We can't delete the hash table entry - * before invoking the deletion callback because there are cases - * where the deletion callback needs to invoke the command (e.g. - * object systems such as OTcl). However, this means that the - * callback could try to delete or rename the command. The deleted - * flag allows us to detect these cases and skip nested deletes. - */ - - if (cmdPtr->deleted) { - - /* - * Another deletion is already in progress. Remove the hash - * table entry now, but don't invoke a callback or free the - * command structure. - */ - - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = NULL; - return 0; - } - cmdPtr->deleted = 1; - if (cmdPtr->deleteProc != NULL) { - (*cmdPtr->deleteProc)(cmdPtr->deleteData); - } - - /* - * The code below provides more backwards compatibility for the - * renaming of "tkerror" to "bgerror". Like the code above, this - * code should eventually become unnecessary. - */ - - if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) { - - /* - * When the "bgerror" command is deleted, delete "tkerror" - * as well. It shared the same Command structure as "bgerror", - * so all we have to do is throw away the hash table entry. - * NOTE: we have to be careful since tkerror may already have - * been deleted before bgerror. - */ - - tkErrorHPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror"); - if (tkErrorHPtr != (Tcl_HashEntry *) NULL) { - Tcl_DeleteHashEntry(tkErrorHPtr); - } - } - - /* - * Don't use hPtr to delete the hash entry here, because it's - * possible that the deletion callback renamed the command. - * Instead, use cmdPtr->hptr, and make sure that no-one else - * has already deleted the hash entry. - */ - - if (cmdPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(cmdPtr->hPtr); - } - ckfree((char *) cmdPtr); - - return 0; -} - -/* - *----------------------------------------------------------------- - * - * Tcl_Eval -- - * - * Parse and execute a command in the Tcl language. - * - * Results: - * The return value is one of the return codes defined in tcl.hd - * (such as TCL_OK), and interp->result contains a string value - * to supplement the return code. The value of interp->result - * will persist only until the next call to Tcl_Eval: copy it or - * lose it! *TermPtr is filled in with the character just after - * the last one that was part of the command (usually a NULL - * character or a closing bracket). - * - * Side effects: - * Almost certainly; depends on the command. - * - *----------------------------------------------------------------- - */ - -int -Tcl_Eval( - Tcl_Interp *interp, /* Token for command interpreter (returned - * by a previous call to Tcl_CreateInterp). */ - char *cmd /* Pointer to TCL command to interpret. */ -) -{ - /* - * The storage immediately below is used to generate a copy - * of the command, after all argument substitutions. Pv will - * contain the argv values passed to the command procedure. - */ - -# define NUM_CHARS 200 - char copyStorage[NUM_CHARS]; - ParseValue pv; - char *oldBuffer; - - /* - * This procedure generates an (argv, argc) array for the command, - * It starts out with stack-allocated space but uses dynamically- - * allocated storage to increase it if needed. - */ - -# define NUM_ARGS 10 - char *(argStorage[NUM_ARGS]); - char **argv = argStorage; - int argc; - int argSize = NUM_ARGS; - - char *src; /* Points to current character - * in cmd. */ - char termChar; /* Return when this character is found - * (either ']' or '\0'). Zero means - * that newlines terminate commands. */ - int flags; /* Interp->evalFlags value when the - * procedure was called. */ - int result; /* Return value. */ - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - Command *cmdPtr; - char *termPtr; /* Contains character just after the - * last one in the command. */ - char *cmdStart; /* Points to first non-blank char. in - * command (used in calling trace - * procedures). */ - char *ellipsis = ""; /* Used in setting errorInfo variable; - * set to "..." to indicate that not - * all of offending command is included - * in errorInfo. "" means that the - * command is all there. */ - Trace *tracePtr; - int oldCount = iPtr->cmdCount; /* Used to tell whether any commands - * at all were executed. */ - - /* - * Initialize the result to an empty string and clear out any - * error information. This makes sure that we return an empty - * result if there are no commands in the command string. - */ - - Tcl_FreeResult((Tcl_Interp *) iPtr); - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; - result = TCL_OK; - - /* - * Initialize the area in which command copies will be assembled. - */ - - pv.buffer = copyStorage; - pv.end = copyStorage + NUM_CHARS - 1; - pv.expandProc = TclExpandParseValue; - pv.clientData = (ClientData) NULL; - - src = cmd; - flags = iPtr->evalFlags; - iPtr->evalFlags = 0; - if (flags & TCL_BRACKET_TERM) { - termChar = ']'; - } else { - termChar = 0; - } - termPtr = src; - cmdStart = src; - - /* - * Check depth of nested calls to Tcl_Eval: if this gets too large, - * it's probably because of an infinite loop somewhere. - */ - - iPtr->numLevels++; - if (iPtr->numLevels > iPtr->maxNestingDepth) { - iPtr->numLevels--; - iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; - iPtr->termPtr = termPtr; - return TCL_ERROR; - } - - /* - * There can be many sub-commands (separated by semi-colons or - * newlines) in one command string. This outer loop iterates over - * individual commands. - */ - - while (*src != termChar) { - - /* - * If we have been deleted, return an error preventing further - * evals. - */ - - if (iPtr->flags & DELETED) { - Tcl_ResetResult(interp); - interp->result = "attempt to call eval in deleted interpreter"; - Tcl_SetErrorCode(interp, "CORE", "IDELETE", interp->result, - (char *) NULL); - iPtr->numLevels--; - return TCL_ERROR; - } - - iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET); - - /* - * Skim off leading white space and semi-colons, and skip - * comments. - */ - - while (1) { - char c = *src; - - if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) { - break; - } - src += 1; - } - if (*src == '#') { - while (*src != 0) { - if (*src == '\\') { - int length; - Tcl_Backslash(src, &length); - src += length; - } else if (*src == '\n') { - src++; - termPtr = src; - break; - } else { - src++; - } - } - continue; - } - cmdStart = src; - - /* - * Parse the words of the command, generating the argc and - * argv for the command procedure. May have to call - * TclParseWords several times, expanding the argv array - * between calls. - */ - - pv.next = oldBuffer = pv.buffer; - argc = 0; - while (1) { - int newArgs, maxArgs; - char **newArgv; - int i; - - /* - * Note: the "- 2" below guarantees that we won't use the - * last two argv slots here. One is for a NULL pointer to - * mark the end of the list, and the other is to leave room - * for inserting the command name "unknown" as the first - * argument (see below). - */ - - maxArgs = argSize - argc - 2; - result = TclParseWords((Tcl_Interp *) iPtr, src, flags, - maxArgs, &termPtr, &newArgs, &argv[argc], &pv); - src = termPtr; - if (result != TCL_OK) { - ellipsis = "..."; - goto done; - } - - /* - * Careful! Buffer space may have gotten reallocated while - * parsing words. If this happened, be sure to update all - * of the older argv pointers to refer to the new space. - */ - - if (oldBuffer != pv.buffer) { - int i; - - for (i = 0; i < argc; i++) { - argv[i] = pv.buffer + (argv[i] - oldBuffer); - } - oldBuffer = pv.buffer; - } - argc += newArgs; - if (newArgs < maxArgs) { - argv[argc] = (char *) NULL; - break; - } - - /* - * Args didn't all fit in the current array. Make it bigger. - */ - - argSize *= 2; - newArgv = (char **) - ckalloc((unsigned) argSize * sizeof(char *)); - for (i = 0; i < argc; i++) { - newArgv[i] = argv[i]; - } - if (argv != argStorage) { - ckfree((char *) argv); - } - argv = newArgv; - } - - /* - * If this is an empty command (or if we're just parsing - * commands without evaluating them), then just skip to the - * next command. - */ - - if ((argc == 0) || iPtr->noEval) { - continue; - } - argv[argc] = NULL; - - /* - * Save information for the history module, if needed. - */ - - if (flags & TCL_RECORD_BOUNDS) { - iPtr->evalFirst = cmdStart; - iPtr->evalLast = src-1; - } - - /* - * Find the procedure to execute this command. If there isn't - * one, then see if there is a command "unknown". If so, - * invoke it instead, passing it the words of the original - * command as arguments. - */ - - hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]); - if (hPtr == NULL) { - int i; - - hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown"); - if (hPtr == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "invalid command name \"", - argv[0], "\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - for (i = argc; i >= 0; i--) { - argv[i+1] = argv[i]; - } - argv[0] = "unknown"; - argc++; - } - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - - /* - * Call trace procedures, if any. - */ - - for (tracePtr = iPtr->tracePtr; tracePtr != NULL; - tracePtr = tracePtr->nextPtr) { - char saved; - - if (tracePtr->level < iPtr->numLevels) { - continue; - } - saved = *src; - *src = 0; - (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, - cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv); - *src = saved; - } - - /* - * At long last, invoke the command procedure. Reset the - * result to its default empty value first (it could have - * gotten changed by earlier commands in the same command - * string). - */ - - iPtr->cmdCount++; - Tcl_FreeResult(iPtr); - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; - result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv); - if (Tcl_AsyncReady()) { - result = Tcl_AsyncInvoke(interp, result); - } - if (result != TCL_OK) { - break; - } - } - - done: - - /* - * If no commands at all were executed, check for asynchronous - * handlers so that they at least get one change to execute. - * This is needed to handle event loops written in Tcl with - * empty bodies (I'm not sure that loops like this are a good - * idea, * but...). - */ - - if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) { - result = Tcl_AsyncInvoke(interp, result); - } - - /* - * Free up any extra resources that were allocated. - */ - - if (pv.buffer != copyStorage) { - ckfree((char *) pv.buffer); - } - if (argv != argStorage) { - ckfree((char *) argv); - } - iPtr->numLevels--; - if (iPtr->numLevels == 0) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } - if ((result != TCL_OK) && (result != TCL_ERROR) - && !(flags & TCL_ALLOW_EXCEPTIONS)) { - Tcl_ResetResult(interp); - if (result == TCL_BREAK) { - iPtr->result = "invoked \"break\" outside of a loop"; - } else if (result == TCL_CONTINUE) { - iPtr->result = "invoked \"continue\" outside of a loop"; - } else { - iPtr->result = iPtr->resultSpace; - sprintf(iPtr->resultSpace, "command returned bad code: %d", - result); - } - result = TCL_ERROR; - } - } - - /* - * If an error occurred, record information about what was being - * executed when the error occurred. - */ - - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - int numChars; - char *p; - - /* - * Compute the line number where the error occurred. - */ - - iPtr->errorLine = 1; - for (p = cmd; p != cmdStart; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - /* - * Figure out how much of the command to print in the error - * message (up to a certain number of characters, or up to - * the first new-line). - */ - - numChars = src - cmdStart; - if (numChars > (NUM_CHARS-50)) { - numChars = NUM_CHARS-50; - ellipsis = " ..."; - } - - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - sprintf(copyStorage, "\n while executing\n\"%.*s%s\"", - numChars, cmdStart, ellipsis); - } else { - sprintf(copyStorage, "\n invoked from within\n\"%.*s%s\"", - numChars, cmdStart, ellipsis); - } - Tcl_AddErrorInfo(interp, copyStorage); - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } else { - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } - iPtr->termPtr = termPtr; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateTrace -- - * - * Arrange for a procedure to be called to trace command execution. - * - * Results: - * The return value is a token for the trace, which may be passed - * to Tcl_DeleteTrace to eliminate the trace. - * - * Side effects: - * From now on, proc will be called just before a command procedure - * is called to execute a Tcl command. Calls to proc will have the - * following form: - * - * void - * proc(clientData, interp, level, command, cmdProc, cmdClientData, - * argc, argv) - * ClientData clientData; - * Tcl_Interp *interp; - * int level; - * char *command; - * int (*cmdProc)(); - * ClientData cmdClientData; - * int argc; - * char **argv; - * { - * } - * - * The clientData and interp arguments to proc will be the same - * as the corresponding arguments to this procedure. Level gives - * the nesting level of command interpretation for this interpreter - * (0 corresponds to top level). Command gives the ASCII text of - * the raw command, cmdProc and cmdClientData give the procedure that - * will be called to process the command and the ClientData value it - * will receive, and argc and argv give the arguments to the - * command, after any argument parsing and substitution. Proc - * does not return a value. - * - *---------------------------------------------------------------------- - */ - -Tcl_Trace -Tcl_CreateTrace( - Tcl_Interp *interp, /* Interpreter in which to create the trace. */ - int level, /* Only call proc for commands at nesting level - * <= level (1 => top level). */ - Tcl_CmdTraceProc *proc, /* Procedure to call before executing each - * command. */ - ClientData clientData /* Arbitrary one-word value to pass to proc. */ -) -{ - Trace *tracePtr; - Interp *iPtr = (Interp *) interp; - - tracePtr = (Trace *) ckalloc(sizeof(Trace)); - tracePtr->level = level; - tracePtr->proc = proc; - tracePtr->clientData = clientData; - tracePtr->nextPtr = iPtr->tracePtr; - iPtr->tracePtr = tracePtr; - - return (Tcl_Trace) tracePtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteTrace -- - * - * Remove a trace. - * - * Results: - * None. - * - * Side effects: - * From now on there will be no more calls to the procedure given - * in trace. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteTrace( - Tcl_Interp *interp, /* Interpreter that contains trace. */ - Tcl_Trace trace /* Token for trace (returned previously by - * Tcl_CreateTrace). */ -) -{ - Interp *iPtr = (Interp *) interp; - Trace *tracePtr = (Trace *) trace; - Trace *tracePtr2; - - if (iPtr->tracePtr == tracePtr) { - iPtr->tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); - } else { - for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL; - tracePtr2 = tracePtr2->nextPtr) { - if (tracePtr2->nextPtr == tracePtr) { - tracePtr2->nextPtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); - return; - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AddErrorInfo -- - * - * Add information to a message being accumulated that describes - * the current error. - * - * Results: - * None. - * - * Side effects: - * The contents of message are added to the "errorInfo" variable. - * If Tcl_Eval has been called since the current value of errorInfo - * was set, errorInfo is cleared before adding the new message. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AddErrorInfo( - Tcl_Interp *interp, /* Interpreter to which error information - * pertains. */ - char *message /* Message to record. */ -) -{ - Interp *iPtr = (Interp *) interp; - - /* - * If an error is already being logged, then the new errorInfo - * is the concatenation of the old info and the new message. - * If this is the first piece of info for the error, then the - * new errorInfo is the concatenation of the message in - * interp->result and the new message. - */ - - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, - TCL_GLOBAL_ONLY); - iPtr->flags |= ERR_IN_PROGRESS; - - /* - * If the errorCode variable wasn't set by the code that generated - * the error, set it to "NONE". - */ - - if (!(iPtr->flags & ERROR_CODE_SET)) { - (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE", - TCL_GLOBAL_ONLY); - } - } - Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message, - TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_VarEval -- - * - * Given a variable number of string arguments, concatenate them - * all together and execute the result as a Tcl command. - * - * Results: - * A standard Tcl return result. An error message or other - * result may be left in interp->result. - * - * Side effects: - * Depends on what was done by the command. - * - *---------------------------------------------------------------------- - */ - /* VARARGS2 */ /* ARGSUSED */ -int -Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *, arg1) -{ - va_list argList; - Tcl_DString buf; - char *string; - Tcl_Interp *interp; - int result; - - /* - * Copy the strings one after the other into a single larger - * string. Use stack-allocated space for small commands, but if - * the command gets too large than call ckalloc to create the - * space. - */ - - interp = arg1; - va_start(argList, arg1); - - Tcl_DStringInit(&buf); - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - Tcl_DStringAppend(&buf, string, -1); - } - va_end(argList); - - result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); - Tcl_DStringFree(&buf); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GlobalEval -- - * - * Evaluate a command at global level in an interpreter. - * - * Results: - * A standard Tcl result is returned, and interp->result is - * modified accordingly. - * - * Side effects: - * The command string is executed in interp, and the execution - * is carried out in the variable context of global level (no - * procedures active), just as if an "uplevel #0" command were - * being executed. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GlobalEval( - Tcl_Interp *interp, /* Interpreter in which to evaluate command. */ - char *command /* Command to evaluate. */ -) -{ - Interp *iPtr = (Interp *) interp; - int result; - CallFrame *savedVarFramePtr; - - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = NULL; - result = Tcl_Eval(interp, command); - iPtr->varFramePtr = savedVarFramePtr; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetRecursionLimit -- - * - * Set the maximum number of recursive calls that may be active - * for an interpreter at once. - * - * Results: - * The return value is the old limit on nesting for interp. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetRecursionLimit( - Tcl_Interp *interp, /* Interpreter whose nesting limit - * is to be set. */ - int depth /* New value for maximimum depth. */ -) -{ - Interp *iPtr = (Interp *) interp; - int old; - - old = iPtr->maxNestingDepth; - if (depth > 0) { - iPtr->maxNestingDepth = depth; - } - return old; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AllowExceptions -- - * - * Sets a flag in an interpreter so that exceptions can occur - * in the next call to Tcl_Eval without them being turned into - * errors. - * - * Results: - * None. - * - * Side effects: - * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's - * evalFlags structure. See the reference documentation for - * more details. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AllowExceptions( - Tcl_Interp *interp /* Interpreter in which to set flag. */ -) -{ - Interp *iPtr = (Interp *) interp; - - iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; -} diff --git a/cde/programs/dtdocbook/tcl/tclCkalloc.c b/cde/programs/dtdocbook/tcl/tclCkalloc.c deleted file mode 100644 index 123db466..00000000 --- a/cde/programs/dtdocbook/tcl/tclCkalloc.c +++ /dev/null @@ -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 diff --git a/cde/programs/dtdocbook/tcl/tclClock.c b/cde/programs/dtdocbook/tcl/tclClock.c deleted file mode 100644 index c495c489..00000000 --- a/cde/programs/dtdocbook/tcl/tclClock.c +++ /dev/null @@ -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; -} - diff --git a/cde/programs/dtdocbook/tcl/tclCmdAH.c b/cde/programs/dtdocbook/tcl/tclCmdAH.c deleted file mode 100644 index 19f62d9e..00000000 --- a/cde/programs/dtdocbook/tcl/tclCmdAH.c +++ /dev/null @@ -1,1715 +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: tclCmdAH.c /main/2 1996/08/08 14:43:11 cde-hp $ */ -/* - * tclCmdAH.c -- - * - * This file contains the top-level command routines for most of - * the Tcl built-in commands whose names begin with the letters - * A to H. - * - * Copyright (c) 1987-1993 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: @(#) tclCmdAH.c 1.107 96/04/09 17:14:39 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * Prototypes for local procedures defined in this file: - */ - -static char * GetTypeFromMode _ANSI_ARGS_((int mode)); -static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, - char *varName, struct stat *statPtr)); - -/* - *---------------------------------------------------------------------- - * - * Tcl_BreakCmd -- - * - * This procedure is invoked to process the "break" 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_BreakCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], "\"", (char *) NULL); - return TCL_ERROR; - } - return TCL_BREAK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CaseCmd -- - * - * This procedure is invoked to process the "case" 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_CaseCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int i, result; - int body; - char *string; - int caseArgc, splitArgs; - char **caseArgv; - - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " string ?in? patList body ... ?default body?\"", - (char *) NULL); - return TCL_ERROR; - } - string = argv[1]; - body = -1; - if (strcmp(argv[2], "in") == 0) { - i = 3; - } else { - i = 2; - } - caseArgc = argc - i; - caseArgv = argv + i; - - /* - * If all of the pattern/command pairs are lumped into a single - * argument, split them out again. - */ - - splitArgs = 0; - if (caseArgc == 1) { - result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv); - if (result != TCL_OK) { - return result; - } - splitArgs = 1; - } - - for (i = 0; i < caseArgc; i += 2) { - int patArgc, j; - char **patArgv; - char *p; - - if (i == (caseArgc-1)) { - interp->result = "extra case pattern with no body"; - result = TCL_ERROR; - goto cleanup; - } - - /* - * Check for special case of single pattern (no list) with - * no backslash sequences. - */ - - for (p = caseArgv[i]; *p != 0; p++) { - if (isspace(UCHAR(*p)) || (*p == '\\')) { - break; - } - } - if (*p == 0) { - if ((*caseArgv[i] == 'd') - && (strcmp(caseArgv[i], "default") == 0)) { - body = i+1; - } - if (Tcl_StringMatch(string, caseArgv[i])) { - body = i+1; - goto match; - } - continue; - } - - /* - * Break up pattern lists, then check each of the patterns - * in the list. - */ - - result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv); - if (result != TCL_OK) { - goto cleanup; - } - for (j = 0; j < patArgc; j++) { - if (Tcl_StringMatch(string, patArgv[j])) { - body = i+1; - break; - } - } - ckfree((char *) patArgv); - if (j < patArgc) { - break; - } - } - - match: - if (body != -1) { - result = Tcl_Eval(interp, caseArgv[body]); - if (result == TCL_ERROR) { - char msg[100]; - sprintf(msg, "\n (\"%.50s\" arm line %d)", caseArgv[body-1], - interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - goto cleanup; - } - - /* - * Nothing matched: return nothing. - */ - - result = TCL_OK; - - cleanup: - if (splitArgs) { - ckfree((char *) caseArgv); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CatchCmd -- - * - * This procedure is invoked to process the "catch" 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_CatchCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int result; - - if ((argc != 2) && (argc != 3)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " command ?varName?\"", (char *) NULL); - return TCL_ERROR; - } - result = Tcl_Eval(interp, argv[1]); - if (argc == 3) { - if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) { - Tcl_SetResult(interp, "couldn't save command result in variable", - TCL_STATIC); - return TCL_ERROR; - } - } - Tcl_ResetResult(interp); - sprintf(interp->result, "%d", result); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CdCmd -- - * - * This procedure is invoked to process the "cd" 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_CdCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - char *dirName; - Tcl_DString buffer; - int result; - - if (argc > 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " dirName\"", (char *) NULL); - return TCL_ERROR; - } - - if (argc == 2) { - dirName = argv[1]; - } else { - dirName = "~"; - } - dirName = Tcl_TranslateFileName(interp, dirName, &buffer); - if (dirName == NULL) { - return TCL_ERROR; - } - result = TclChdir(interp, dirName); - Tcl_DStringFree(&buffer); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ConcatCmd -- - * - * This procedure is invoked to process the "concat" 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_ConcatCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - if (argc >= 2) { - interp->result = Tcl_Concat(argc-1, argv+1); - interp->freeProc = TCL_DYNAMIC; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ContinueCmd -- - * - * This procedure is invoked to process the "continue" 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_ContinueCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - "\"", (char *) NULL); - return TCL_ERROR; - } - return TCL_CONTINUE; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ErrorCmd -- - * - * This procedure is invoked to process the "error" 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_ErrorCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Interp *iPtr = (Interp *) interp; - - if ((argc < 2) || (argc > 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " message ?errorInfo? ?errorCode?\"", (char *) NULL); - return TCL_ERROR; - } - if ((argc >= 3) && (argv[2][0] != 0)) { - Tcl_AddErrorInfo(interp, argv[2]); - iPtr->flags |= ERR_ALREADY_LOGGED; - } - if (argc == 4) { - Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3], - TCL_GLOBAL_ONLY); - iPtr->flags |= ERROR_CODE_SET; - } - Tcl_SetResult(interp, argv[1], TCL_VOLATILE); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalCmd -- - * - * This procedure is invoked to process the "eval" 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_EvalCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int result; - char *cmd; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " arg ?arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 2) { - result = Tcl_Eval(interp, argv[1]); - } else { - - /* - * More than one argument: concatenate them together with spaces - * between, then evaluate the result. - */ - - cmd = Tcl_Concat(argc-1, argv+1); - result = Tcl_Eval(interp, cmd); - ckfree(cmd); - } - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ExitCmd -- - * - * This procedure is invoked to process the "exit" 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_ExitCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int value; - - if ((argc != 1) && (argc != 2)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?returnCode?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 1) { - value = 0; - } else if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) { - return TCL_ERROR; - } - Tcl_Exit(value); - /*NOTREACHED*/ - return TCL_OK; /* Better not ever reach this! */ -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ExprCmd -- - * - * This procedure is invoked to process the "expr" 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_ExprCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_DString buffer; - int i, result; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " arg ?arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - - if (argc == 2) { - return Tcl_ExprString(interp, argv[1]); - } - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, argv[1], -1); - for (i = 2; i < argc; i++) { - Tcl_DStringAppend(&buffer, " ", 1); - Tcl_DStringAppend(&buffer, argv[i], -1); - } - result = Tcl_ExprString(interp, buffer.string); - Tcl_DStringFree(&buffer); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FileCmd -- - * - * This procedure is invoked to process the "file" 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_FileCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - char *fileName, *extension; - int c, statOp, result; - size_t length; - int mode = 0; /* Initialized only to prevent - * compiler warning message. */ - struct stat statBuf; - Tcl_DString buffer; - - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option name ?arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - c = argv[1][0]; - length = strlen(argv[1]); - result = TCL_OK; - Tcl_DStringInit(&buffer); - - /* - * First handle operations on the file name. - */ - - if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) { - int pargc; - char **pargv; - - if (argc != 3) { - argv[1] = "dirname"; - goto not3Args; - } - - fileName = argv[2]; - - /* - * If there is only one element, and it starts with a tilde, - * perform tilde substitution and resplit the path. - */ - - Tcl_SplitPath(fileName, &pargc, &pargv); - if ((pargc == 1) && (*fileName == '~')) { - ckfree((char*) pargv); - fileName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (fileName == NULL) { - result = TCL_ERROR; - goto done; - } - Tcl_SplitPath(fileName, &pargc, &pargv); - Tcl_DStringSetLength(&buffer, 0); - } - - /* - * Return all but the last component. If there is only one - * component, return it if the path was non-relative, otherwise - * return the current directory. - */ - - if (pargc > 1) { - Tcl_JoinPath(pargc-1, pargv, &buffer); - Tcl_DStringResult(interp, &buffer); - } else if ((pargc == 0) - || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetResult(interp, - (tclPlatform == TCL_PLATFORM_MAC) ? ":" : ".", TCL_STATIC); - } else { - Tcl_SetResult(interp, pargv[0], TCL_VOLATILE); - } - ckfree((char *)pargv); - goto done; - - } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0) - && (length >= 2)) { - int pargc; - char **pargv; - - if (argc != 3) { - argv[1] = "tail"; - goto not3Args; - } - - Tcl_SplitPath(argv[2], &pargc, &pargv); - if (pargc > 0) { - if ((pargc > 1) - || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetResult(interp, pargv[pargc-1], TCL_VOLATILE); - } - } - ckfree((char *)pargv); - goto done; - - } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0) - && (length >= 2)) { - char tmp; - if (argc != 3) { - argv[1] = "rootname"; - goto not3Args; - } - extension = TclGetExtension(argv[2]); - if (extension == NULL) { - Tcl_SetResult(interp, argv[2], TCL_VOLATILE); - } else { - tmp = *extension; - *extension = 0; - Tcl_SetResult(interp, argv[2], TCL_VOLATILE); - *extension = tmp; - } - goto done; - } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0) - && (length >= 3)) { - if (argc != 3) { - argv[1] = "extension"; - goto not3Args; - } - extension = TclGetExtension(argv[2]); - - if (extension != NULL) { - Tcl_SetResult(interp, extension, TCL_VOLATILE); - } - goto done; - } else if ((c == 'p') && (strncmp(argv[1], "pathtype", length) == 0)) { - if (argc != 3) { - argv[1] = "pathtype"; - goto not3Args; - } - switch (Tcl_GetPathType(argv[2])) { - case TCL_PATH_ABSOLUTE: - Tcl_SetResult(interp, "absolute", TCL_STATIC); - break; - case TCL_PATH_RELATIVE: - Tcl_SetResult(interp, "relative", TCL_STATIC); - break; - case TCL_PATH_VOLUME_RELATIVE: - Tcl_SetResult(interp, "volumerelative", TCL_STATIC); - break; - } - goto done; - } else if ((c == 's') && (strncmp(argv[1], "split", length) == 0) - && (length >= 2)) { - int pargc, i; - char **pargvList; - - if (argc != 3) { - argv[1] = "split"; - goto not3Args; - } - - Tcl_SplitPath(argv[2], &pargc, &pargvList); - for (i = 0; i < pargc; i++) { - Tcl_AppendElement(interp, pargvList[i]); - } - ckfree((char *) pargvList); - goto done; - } else if ((c == 'j') && (strncmp(argv[1], "join", length) == 0)) { - Tcl_JoinPath(argc-2, argv+2, &buffer); - Tcl_DStringResult(interp, &buffer); - goto done; - } - - /* - * Next, handle operations that can be satisfied with the "access" - * kernel call. - */ - - fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); - if (fileName == NULL) { - result = TCL_ERROR; - goto done; - } - if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0) - && (length >= 5)) { - if (argc != 3) { - argv[1] = "readable"; - goto not3Args; - } - mode = R_OK; - checkAccess: - if (access(fileName, mode) == -1) { - interp->result = "0"; - } else { - interp->result = "1"; - } - goto done; - } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) { - if (argc != 3) { - argv[1] = "writable"; - goto not3Args; - } - mode = W_OK; - goto checkAccess; - } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0) - && (length >= 3)) { - if (argc != 3) { - argv[1] = "executable"; - goto not3Args; - } - mode = X_OK; - goto checkAccess; - } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0) - && (length >= 3)) { - if (argc != 3) { - argv[1] = "exists"; - goto not3Args; - } - mode = F_OK; - goto checkAccess; - } - - /* - * Lastly, check stuff that requires the file to be stat-ed. - */ - - if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) { - if (argc != 3) { - argv[1] = "atime"; - goto not3Args; - } - if (stat(fileName, &statBuf) == -1) { - goto badStat; - } - sprintf(interp->result, "%ld", (long) statBuf.st_atime); - goto done; - } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0) - && (length >= 3)) { - if (argc != 3) { - argv[1] = "isdirectory"; - goto not3Args; - } - statOp = 2; - } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0) - && (length >= 3)) { - if (argc != 3) { - argv[1] = "isfile"; - goto not3Args; - } - statOp = 1; - } else if ((c == 'l') && (strncmp(argv[1], "lstat", length) == 0)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " lstat name varName\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - - if (lstat(fileName, &statBuf) == -1) { - Tcl_AppendResult(interp, "couldn't lstat \"", argv[2], - "\": ", Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; - } - result = StoreStatData(interp, argv[3], &statBuf); - goto done; - } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) { - if (argc != 3) { - argv[1] = "mtime"; - goto not3Args; - } - if (stat(fileName, &statBuf) == -1) { - goto badStat; - } - sprintf(interp->result, "%ld", (long) statBuf.st_mtime); - goto done; - } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) { - if (argc != 3) { - argv[1] = "owned"; - goto not3Args; - } - statOp = 0; - } else if ((c == 'r') && (strncmp(argv[1], "readlink", length) == 0) - && (length >= 5)) { - char linkValue[MAXPATHLEN+1]; - int linkLength; - - if (argc != 3) { - argv[1] = "readlink"; - goto not3Args; - } - - /* - * If S_IFLNK isn't defined it means that the machine doesn't - * support symbolic links, so the file can't possibly be a - * symbolic link. Generate an EINVAL error, which is what - * happens on machines that do support symbolic links when - * you invoke readlink on a file that isn't a symbolic link. - */ - -#ifndef S_IFLNK - linkLength = -1; - errno = EINVAL; -#else - linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1); -#endif /* S_IFLNK */ - if (linkLength == -1) { - Tcl_AppendResult(interp, "couldn't readlink \"", argv[2], - "\": ", Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; - } - linkValue[linkLength] = 0; - Tcl_SetResult(interp, linkValue, TCL_VOLATILE); - goto done; - } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) - && (length >= 2)) { - if (argc != 3) { - argv[1] = "size"; - goto not3Args; - } - if (stat(fileName, &statBuf) == -1) { - goto badStat; - } - sprintf(interp->result, "%lu", (unsigned long) statBuf.st_size); - goto done; - } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0) - && (length >= 2)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " stat name varName\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - - if (stat(fileName, &statBuf) == -1) { - badStat: - Tcl_AppendResult(interp, "couldn't stat \"", argv[2], - "\": ", Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; - } - result = StoreStatData(interp, argv[3], &statBuf); - goto done; - } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0) - && (length >= 2)) { - if (argc != 3) { - argv[1] = "type"; - goto not3Args; - } - if (lstat(fileName, &statBuf) == -1) { - goto badStat; - } - interp->result = GetTypeFromMode((int) statBuf.st_mode); - goto done; - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be atime, dirname, executable, exists, ", - "extension, isdirectory, isfile, join, ", - "lstat, mtime, owned, pathtype, readable, readlink, ", - "root, size, split, stat, tail, type, ", - "or writable", - (char *) NULL); - result = TCL_ERROR; - goto done; - } - if (stat(fileName, &statBuf) == -1) { - interp->result = "0"; - goto done; - } - switch (statOp) { - case 0: - /* - * For Windows and Macintosh, there are no user ids - * associated with a file, so we always return 1. - */ - -#if (defined(__WIN32__) || defined(MAC_TCL)) - mode = 1; -#else - mode = (geteuid() == statBuf.st_uid); -#endif - break; - case 1: - mode = S_ISREG(statBuf.st_mode); - break; - case 2: - mode = S_ISDIR(statBuf.st_mode); - break; - } - if (mode) { - interp->result = "1"; - } else { - interp->result = "0"; - } - - done: - Tcl_DStringFree(&buffer); - return result; - - not3Args: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " name\"", (char *) NULL); - result = TCL_ERROR; - goto done; -} - -/* - *---------------------------------------------------------------------- - * - * StoreStatData -- - * - * This is a utility procedure that breaks out the fields of a - * "stat" structure and stores them in textual form into the - * elements of an associative array. - * - * Results: - * Returns a standard Tcl return value. If an error occurs then - * a message is left in interp->result. - * - * Side effects: - * Elements of the associative array given by "varName" are modified. - * - *---------------------------------------------------------------------- - */ - -static int -StoreStatData( - Tcl_Interp *interp, /* Interpreter for error reports. */ - char *varName, /* Name of associative array variable - * in which to store stat results. */ - struct stat *statPtr /* Pointer to buffer containing - * stat data to store in varName. */ -) -{ - char string[30]; - - sprintf(string, "%ld", (long) statPtr->st_dev); - if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - sprintf(string, "%ld", (long) statPtr->st_ino); - if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - sprintf(string, "%ld", (long) statPtr->st_mode); - if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - sprintf(string, "%ld", (long) statPtr->st_nlink); - if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - sprintf(string, "%ld", (long) statPtr->st_uid); - if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - sprintf(string, "%ld", (long) statPtr->st_gid); - if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - sprintf(string, "%lu", (unsigned long) statPtr->st_size); - if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - sprintf(string, "%ld", (long) statPtr->st_atime); - if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - sprintf(string, "%ld", (long) statPtr->st_mtime); - if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - sprintf(string, "%ld", (long) statPtr->st_ctime); - if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - if (Tcl_SetVar2(interp, varName, "type", - GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * GetTypeFromMode -- - * - * Given a mode word, returns a string identifying the type of a - * file. - * - * Results: - * A static text string giving the file type from mode. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -GetTypeFromMode(int mode) -{ - if (S_ISREG(mode)) { - return "file"; - } else if (S_ISDIR(mode)) { - return "directory"; - } else if (S_ISCHR(mode)) { - return "characterSpecial"; - } else if (S_ISBLK(mode)) { - return "blockSpecial"; - } else if (S_ISFIFO(mode)) { - return "fifo"; - } else if (S_ISLNK(mode)) { - return "link"; - } else if (S_ISSOCK(mode)) { - return "socket"; - } - return "unknown"; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ForCmd -- - * - * This procedure is invoked to process the "for" 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_ForCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int result, value; - - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " start test next command\"", (char *) NULL); - return TCL_ERROR; - } - - result = Tcl_Eval(interp, argv[1]); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); - } - return result; - } - while (1) { - result = Tcl_ExprBoolean(interp, argv[2], &value); - if (result != TCL_OK) { - return result; - } - if (!value) { - break; - } - result = Tcl_Eval(interp, argv[4]); - if ((result != TCL_OK) && (result != TCL_CONTINUE)) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - break; - } - result = Tcl_Eval(interp, argv[3]); - if (result == TCL_BREAK) { - break; - } else if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); - } - return result; - } - } - if (result == TCL_BREAK) { - result = TCL_OK; - } - if (result == TCL_OK) { - Tcl_ResetResult(interp); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ForeachCmd -- - * - * This procedure is invoked to process the "foreach" 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_ForeachCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int result = TCL_OK; - int i; /* i selects a value list */ - int j, maxj; /* Number of loop iterations */ - int v; /* v selects a loop variable */ - int numLists; /* Count of value lists */ -#define STATIC_SIZE 4 - int indexArray[STATIC_SIZE]; /* Array of value list indices */ - int varcListArray[STATIC_SIZE]; /* Number of loop variables per list */ - char **varvListArray[STATIC_SIZE]; /* Array of variable name lists */ - int argcListArray[STATIC_SIZE]; /* Array of value list sizes */ - char **argvListArray[STATIC_SIZE]; /* Array of value lists */ - - int *index = indexArray; - int *varcList = varcListArray; - char ***varvList = varvListArray; - int *argcList = argcListArray; - char ***argvList = argvListArray; - - if (argc < 4 || (argc%2 != 0)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " varList list ?varList list ...? command\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * Manage numList parallel value lists. - * argvList[i] is a value list counted by argcList[i] - * varvList[i] is the list of variables associated with the value list - * varcList[i] is the number of variables associated with the value list - * index[i] is the current pointer into the value list argvList[i] - */ - - numLists = (argc-2)/2; - if (numLists > STATIC_SIZE) { - index = (int *) ckalloc(numLists * sizeof(int)); - varcList = (int *) ckalloc(numLists * sizeof(int)); - varvList = (char ***) ckalloc(numLists * sizeof(char **)); - argcList = (int *) ckalloc(numLists * sizeof(int)); - argvList = (char ***) ckalloc(numLists * sizeof(char **)); - } - for (i=0 ; i maxj) { - maxj = j; - } - } - - /* - * Iterate maxj times through the lists in parallel - * If some value lists run out of values, set loop vars to "" - */ - for (j = 0; j < maxj; j++) { - for (i=0 ; ierrorLine); - Tcl_AddErrorInfo(interp, msg); - break; - } else { - break; - } - } - } - if (result == TCL_OK) { - Tcl_ResetResult(interp); - } -errorReturn: - for (i=0 ; i STATIC_SIZE) { - ckfree((char *) index); - ckfree((char *) varcList); - ckfree((char *) argcList); - ckfree((char *) varvList); - ckfree((char *) argvList); - } -#undef STATIC_SIZE - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FormatCmd -- - * - * This procedure is invoked to process the "format" 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_FormatCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - char *format; /* Used to read characters from the format - * string. */ - char newFormat[40]; /* A new format specifier is generated here. */ - int width; /* Field width from field specifier, or 0 if - * no width given. */ - int precision; /* Field precision from field specifier, or 0 - * if no precision given. */ - int size; /* Number of bytes needed for result of - * conversion, based on type of conversion - * ("e", "s", etc.), width, and precision. */ - int intValue; /* Used to hold value to pass to sprintf, if - * it's a one-word integer or char value */ - char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if - * it's a one-word value. */ - double doubleValue; /* Used to hold value to pass to sprintf if - * it's a double value. */ - int whichValue; /* Indicates which of intValue, ptrValue, - * or doubleValue has the value to pass to - * sprintf, according to the following - * definitions: */ -# define INT_VALUE 0 -# define PTR_VALUE 1 -# define DOUBLE_VALUE 2 - char *dst = interp->result; /* Where result is stored. Starts off at - * interp->resultSpace, but may get dynamically - * re-allocated if this isn't enough. */ - int dstSize = 0; /* Number of non-null characters currently - * stored at dst. */ - int dstSpace = TCL_RESULT_SIZE; - /* Total amount of storage space available - * in dst (not including null terminator. */ - int noPercent; /* Special case for speed: indicates there's - * no field specifier, just a string to copy. */ - int argIndex; /* Index of argument to substitute next. */ - int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style - * specifier has been seen. */ - int gotSequential = 0; /* Non-zero means that a regular sequential - * (non-XPG3) conversion specifier has been - * seen. */ - int useShort; /* Value to be printed is short (half word). */ - char *end; /* Used to locate end of numerical fields. */ - - /* - * This procedure is a bit nasty. The goal is to use sprintf to - * do most of the dirty work. There are several problems: - * 1. this procedure can't trust its arguments. - * 2. we must be able to provide a large enough result area to hold - * whatever's generated. This is hard to estimate. - * 2. there's no way to move the arguments from argv to the call - * to sprintf in a reasonable way. This is particularly nasty - * because some of the arguments may be two-word values (doubles). - * So, what happens here is to scan the format string one % group - * at a time, making many individual calls to sprintf. - */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " formatString ?arg arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - argIndex = 2; - for (format = argv[1]; *format != 0; ) { - char *newPtr = newFormat; - - width = precision = noPercent = useShort = 0; - whichValue = PTR_VALUE; - - /* - * Get rid of any characters before the next field specifier. - */ - - if (*format != '%') { - char *p; - - ptrValue = p = format; - while ((*format != '%') && (*format != 0)) { - *p = *format; - p++; - format++; - } - size = p - ptrValue; - noPercent = 1; - goto doField; - } - - if (format[1] == '%') { - ptrValue = format; - size = 1; - noPercent = 1; - format += 2; - goto doField; - } - - /* - * Parse off a field specifier, compute how many characters - * will be needed to store the result, and substitute for - * "*" size specifiers. - */ - - *newPtr = '%'; - newPtr++; - format++; - if (isdigit(UCHAR(*format))) { - int tmp; - - /* - * Check for an XPG3-style %n$ specification. Note: there - * must not be a mixture of XPG3 specs and non-XPG3 specs - * in the same format string. - */ - - tmp = strtoul(format, &end, 10); - if (*end != '$') { - goto notXpg; - } - format = end+1; - gotXpg = 1; - if (gotSequential) { - goto mixedXPG; - } - argIndex = tmp+1; - if ((argIndex < 2) || (argIndex >= argc)) { - goto badIndex; - } - goto xpgCheckDone; - } - - notXpg: - gotSequential = 1; - if (gotXpg) { - goto mixedXPG; - } - - xpgCheckDone: - while ((*format == '-') || (*format == '#') || (*format == '0') - || (*format == ' ') || (*format == '+')) { - *newPtr = *format; - newPtr++; - format++; - } - if (isdigit(UCHAR(*format))) { - width = strtoul(format, &end, 10); - format = end; - } else if (*format == '*') { - if (argIndex >= argc) { - goto badIndex; - } - if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) { - goto fmtError; - } - argIndex++; - format++; - } - if (width > 1000) { - /* - * Don't allow arbitrarily large widths: could cause core - * dump when we try to allocate a zillion bytes of memory - * below. - */ - - width = 1000; - } else if (width < 0) { - width = 0; - } - if (width != 0) { - sprintf(newPtr, "%d", width); - while (*newPtr != 0) { - newPtr++; - } - } - if (*format == '.') { - *newPtr = '.'; - newPtr++; - format++; - } - if (isdigit(UCHAR(*format))) { - precision = strtoul(format, &end, 10); - format = end; - } else if (*format == '*') { - if (argIndex >= argc) { - goto badIndex; - } - if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) { - goto fmtError; - } - argIndex++; - format++; - } - if (precision != 0) { - sprintf(newPtr, "%d", precision); - while (*newPtr != 0) { - newPtr++; - } - } - if (*format == 'l') { - format++; - } else if (*format == 'h') { - useShort = 1; - *newPtr = 'h'; - newPtr++; - format++; - } - *newPtr = *format; - newPtr++; - *newPtr = 0; - if (argIndex >= argc) { - goto badIndex; - } - switch (*format) { - case 'i': - newPtr[-1] = 'd'; - case 'd': - case 'o': - case 'u': - case 'x': - case 'X': - if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue) - != TCL_OK) { - goto fmtError; - } - whichValue = INT_VALUE; - size = 40 + precision; - break; - case 's': - ptrValue = argv[argIndex]; - size = strlen(argv[argIndex]); - break; - case 'c': - if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue) - != TCL_OK) { - goto fmtError; - } - whichValue = INT_VALUE; - size = 1; - break; - case 'e': - case 'E': - case 'f': - case 'g': - case 'G': - if (Tcl_GetDouble(interp, argv[argIndex], &doubleValue) - != TCL_OK) { - goto fmtError; - } - whichValue = DOUBLE_VALUE; - size = 320; - if (precision > 10) { - size += precision; - } - break; - case 0: - interp->result = - "format string ended in middle of field specifier"; - goto fmtError; - default: - sprintf(interp->result, "bad field specifier \"%c\"", *format); - goto fmtError; - } - argIndex++; - format++; - - /* - * Make sure that there's enough space to hold the formatted - * result, then format it. - */ - - doField: - if (width > size) { - size = width; - } - if ((dstSize + size) > dstSpace) { - char *newDst; - int newSpace; - - newSpace = 2*(dstSize + size); - newDst = (char *) ckalloc((unsigned) newSpace+1); - if (dstSize != 0) { - memcpy((VOID *) newDst, (VOID *) dst, (size_t) dstSize); - } - if (dstSpace != TCL_RESULT_SIZE) { - ckfree(dst); - } - dst = newDst; - dstSpace = newSpace; - } - if (noPercent) { - memcpy((VOID *) (dst+dstSize), (VOID *) ptrValue, (size_t) size); - dstSize += size; - dst[dstSize] = 0; - } else { - if (whichValue == DOUBLE_VALUE) { - sprintf(dst+dstSize, newFormat, doubleValue); - } else if (whichValue == INT_VALUE) { - if (useShort) { - sprintf(dst+dstSize, newFormat, (short) intValue); - } else { - sprintf(dst+dstSize, newFormat, intValue); - } - } else { - sprintf(dst+dstSize, newFormat, ptrValue); - } - dstSize += strlen(dst+dstSize); - } - } - - interp->result = dst; - if (dstSpace != TCL_RESULT_SIZE) { - interp->freeProc = TCL_DYNAMIC; - } else { - interp->freeProc = 0; - } - return TCL_OK; - - mixedXPG: - interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers"; - goto fmtError; - - badIndex: - if (gotXpg) { - interp->result = "\"%n$\" argument index out of range"; - } else { - interp->result = "not enough arguments for all format specifiers"; - } - - fmtError: - if (dstSpace != TCL_RESULT_SIZE) { - ckfree(dst); - } - return TCL_ERROR; -} diff --git a/cde/programs/dtdocbook/tcl/tclCmdIL.c b/cde/programs/dtdocbook/tcl/tclCmdIL.c deleted file mode 100644 index 87bb5d45..00000000 --- a/cde/programs/dtdocbook/tcl/tclCmdIL.c +++ /dev/null @@ -1,1521 +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: tclCmdIL.c /main/2 1996/08/08 14:43:16 cde-hp $ */ -/* - * tclCmdIL.c -- - * - * This file contains the top-level command routines for most of - * the Tcl built-in commands whose names begin with the letters - * I through L. It contains only commands in the generic core - * (i.e. those that don't depend much upon UNIX facilities). - * - * 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: @(#) tclCmdIL.c 1.119 96/03/22 12:10:14 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * The following variable holds the full path name of the binary - * from which this application was executed, or NULL if it isn't - * know. The value of the variable is set by the procedure - * Tcl_FindExecutable. The storage space is dynamically allocated. - */ - -char *tclExecutableName = NULL; - -/* - * The variables below are used to implement the "lsort" command. - * Unfortunately, this use of static variables prevents "lsort" - * from being thread-safe, but there's no alternative given the - * current implementation of qsort. In a threaded environment - * these variables should be made thread-local if possible, or else - * "lsort" needs internal mutual exclusion. - */ - -static Tcl_Interp *sortInterp = NULL; /* Interpreter for "lsort" command. - * NULL means no lsort is active. */ -static enum {ASCII, INTEGER, REAL, COMMAND} sortMode; - /* Mode for sorting: compare as strings, - * compare as numbers, or call - * user-defined command for - * comparison. */ -static Tcl_DString sortCmd; /* Holds command if mode is COMMAND. - * pre-initialized to hold base of - * command. */ -static int sortIncreasing; /* 0 means sort in decreasing order, - * 1 means increasing order. */ -static int sortCode; /* Anything other than TCL_OK means a - * problem occurred while sorting; this - * executing a comparison command, so - * the sort was aborted. */ - -/* - * Forward declarations for procedures defined in this file: - */ - -static int SortCompareProc _ANSI_ARGS_((CONST VOID *first, - CONST VOID *second)); - -/* - *---------------------------------------------------------------------- - * - * Tcl_IfCmd -- - * - * This procedure is invoked to process the "if" 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_IfCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int i, result, value; - - i = 1; - while (1) { - /* - * At this point in the loop, argv and argc refer to an expression - * to test, either for the main expression or an expression - * following an "elseif". The arguments after the expression must - * be "then" (optional) and a script to execute if the expression is - * true. - */ - - if (i >= argc) { - Tcl_AppendResult(interp, "wrong # args: no expression after \"", - argv[i-1], "\" argument", (char *) NULL); - return TCL_ERROR; - } - result = Tcl_ExprBoolean(interp, argv[i], &value); - if (result != TCL_OK) { - return result; - } - i++; - if ((i < argc) && (strcmp(argv[i], "then") == 0)) { - i++; - } - if (i >= argc) { - Tcl_AppendResult(interp, "wrong # args: no script following \"", - argv[i-1], "\" argument", (char *) NULL); - return TCL_ERROR; - } - if (value) { - return Tcl_Eval(interp, argv[i]); - } - - /* - * The expression evaluated to false. Skip the command, then - * see if there is an "else" or "elseif" clause. - */ - - i++; - if (i >= argc) { - return TCL_OK; - } - if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) { - i++; - continue; - } - break; - } - - /* - * Couldn't find a "then" or "elseif" clause to execute. Check now - * for an "else" clause. We know that there's at least one more - * argument when we get here. - */ - - if (strcmp(argv[i], "else") == 0) { - i++; - if (i >= argc) { - Tcl_AppendResult(interp, - "wrong # args: no script following \"else\" argument", - (char *) NULL); - return TCL_ERROR; - } - } - return Tcl_Eval(interp, argv[i]); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_IncrCmd -- - * - * This procedure is invoked to process the "incr" 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_IncrCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int value; - char *oldString, *result; - char newString[30]; - - if ((argc != 2) && (argc != 3)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " varName ?increment?\"", (char *) NULL); - return TCL_ERROR; - } - - oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG); - if (oldString == NULL) { - return TCL_ERROR; - } - if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) { - Tcl_AddErrorInfo(interp, - "\n (reading value of variable to increment)"); - return TCL_ERROR; - } - if (argc == 2) { - value += 1; - } else { - int increment; - - if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) { - Tcl_AddErrorInfo(interp, - "\n (reading increment)"); - return TCL_ERROR; - } - value += increment; - } - sprintf(newString, "%d", value); - result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG); - if (result == NULL) { - return TCL_ERROR; - } - interp->result = result; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InfoCmd -- - * - * This procedure is invoked to process the "info" 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_InfoCmd( - 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; - Arg *argPtr; - Proc *procPtr; - Var *varPtr; - Command *cmdPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - - 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 == 'a') && (strncmp(argv[1], "args", length)) == 0) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " args procname\"", (char *) NULL); - return TCL_ERROR; - } - procPtr = TclFindProc(iPtr, argv[2]); - if (procPtr == NULL) { - infoNoSuchProc: - Tcl_AppendResult(interp, "\"", argv[2], - "\" isn't a procedure", (char *) NULL); - return TCL_ERROR; - } - for (argPtr = procPtr->argPtr; argPtr != NULL; - argPtr = argPtr->nextPtr) { - Tcl_AppendElement(interp, argPtr->name); - } - return TCL_OK; - } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " body procname\"", (char *) NULL); - return TCL_ERROR; - } - procPtr = TclFindProc(iPtr, argv[2]); - if (procPtr == NULL) { - goto infoNoSuchProc; - } - iPtr->result = procPtr->command; - return TCL_OK; - } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0) - && (length >= 2)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " cmdcount\"", (char *) NULL); - return TCL_ERROR; - } - sprintf(iPtr->result, "%d", iPtr->cmdCount); - return TCL_OK; - } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0) - && (length >= 4)) { - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " commands ?pattern?\"", (char *) NULL); - return TCL_ERROR; - } - for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr); - if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { - continue; - } - Tcl_AppendElement(interp, name); - } - return TCL_OK; - } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0) - && (length >= 4)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " complete command\"", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_CommandComplete(argv[2])) { - interp->result = "1"; - } else { - interp->result = "0"; - } - return TCL_OK; - } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " default procname arg varname\"", - (char *) NULL); - return TCL_ERROR; - } - procPtr = TclFindProc(iPtr, argv[2]); - if (procPtr == NULL) { - goto infoNoSuchProc; - } - for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) { - if (argPtr == NULL) { - Tcl_AppendResult(interp, "procedure \"", argv[2], - "\" doesn't have an argument \"", argv[3], - "\"", (char *) NULL); - return TCL_ERROR; - } - if (strcmp(argv[3], argPtr->name) == 0) { - if (argPtr->defValue != NULL) { - if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], - argPtr->defValue, 0) == NULL) { - defStoreError: - Tcl_AppendResult(interp, - "couldn't store default value in variable \"", - argv[4], "\"", (char *) NULL); - return TCL_ERROR; - } - iPtr->result = "1"; - } else { - if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0) - == NULL) { - goto defStoreError; - } - iPtr->result = "0"; - } - return TCL_OK; - } - } - } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { - char *p; - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " exists varName\"", (char *) NULL); - return TCL_ERROR; - } - p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0); - - /* - * The code below handles the special case where the name is for - * an array: Tcl_GetVar will reject this since you can't read - * an array variable without an index. - */ - - if (p == NULL) { - Tcl_HashEntry *hPtr; - Var *varPtr; - - if (strchr(argv[2], '(') != NULL) { - noVar: - iPtr->result = "0"; - return TCL_OK; - } - if (iPtr->varFramePtr == NULL) { - hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]); - } else { - hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]); - } - if (hPtr == NULL) { - goto noVar; - } - varPtr = (Var *) Tcl_GetHashValue(hPtr); - if (varPtr->flags & VAR_UPVAR) { - varPtr = varPtr->value.upvarPtr; - } - if (!(varPtr->flags & VAR_ARRAY)) { - goto noVar; - } - } - iPtr->result = "1"; - return TCL_OK; - } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) { - char *name; - - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " globals ?pattern?\"", (char *) NULL); - return TCL_ERROR; - } - for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - if (varPtr->flags & VAR_UNDEFINED) { - continue; - } - name = Tcl_GetHashKey(&iPtr->globalTable, hPtr); - if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { - continue; - } - Tcl_AppendElement(interp, name); - } - return TCL_OK; - } else if ((c == 'h') && (strncmp(argv[1], "hostname", length) == 0)) { - if (argc > 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " hostname\"", (char *) NULL); - return TCL_ERROR; - } - Tcl_AppendResult(interp, Tcl_GetHostName(), NULL); - return TCL_OK; - } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0) - && (length >= 2)) { - if (argc == 2) { - if (iPtr->varFramePtr == NULL) { - iPtr->result = "0"; - } else { - sprintf(iPtr->result, "%d", iPtr->varFramePtr->level); - } - return TCL_OK; - } else if (argc == 3) { - int level; - CallFrame *framePtr; - - if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) { - return TCL_ERROR; - } - if (level <= 0) { - if (iPtr->varFramePtr == NULL) { - levelError: - Tcl_AppendResult(interp, "bad level \"", argv[2], - "\"", (char *) NULL); - return TCL_ERROR; - } - level += iPtr->varFramePtr->level; - } - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; - } - } - if (framePtr == NULL) { - goto levelError; - } - iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv); - iPtr->freeProc = TCL_DYNAMIC; - return TCL_OK; - } - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " level [number]\"", (char *) NULL); - return TCL_ERROR; - } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0) - && (length >= 2)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " library\"", (char *) NULL); - return TCL_ERROR; - } - interp->result = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); - if (interp->result == NULL) { - interp->result = "no library has been specified for Tcl"; - return TCL_ERROR; - } - return TCL_OK; - } else if ((c == 'l') && (strncmp(argv[1], "loaded", length) == 0) - && (length >= 3)) { - if ((argc != 2) && (argc != 3)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " loaded ?interp?\"", (char *) NULL); - return TCL_ERROR; - } - return TclGetLoadedPackages(interp, argv[2]); - } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0) - && (length >= 3)) { - char *name; - - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " locals ?pattern?\"", (char *) NULL); - return TCL_ERROR; - } - if (iPtr->varFramePtr == NULL) { - return TCL_OK; - } - for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) { - continue; - } - name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr); - if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { - continue; - } - Tcl_AppendElement(interp, name); - } - return TCL_OK; - } else if ((c == 'n') && (strncmp(argv[1], "nameofexecutable", - length) == 0)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " nameofexecutable\"", (char *) NULL); - return TCL_ERROR; - } - if (tclExecutableName != NULL) { - interp->result = tclExecutableName; - } - return TCL_OK; - } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0) - && (length >= 2)) { - char *value; - - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " patchlevel\"", (char *) NULL); - return TCL_ERROR; - } - value = Tcl_GetVar(interp, "tcl_patchLevel", - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); - if (value == NULL) { - return TCL_ERROR; - } - interp->result = value; - return TCL_OK; - } else if ((c == 'p') && (strncmp(argv[1], "procs", length) == 0) - && (length >= 2)) { - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " procs ?pattern?\"", (char *) NULL); - return TCL_ERROR; - } - for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr); - - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - if (!TclIsProc(cmdPtr)) { - continue; - } - if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { - continue; - } - Tcl_AppendElement(interp, name); - } - return TCL_OK; - } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0) - && (length >= 2)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " script\"", (char *) NULL); - return TCL_ERROR; - } - if (iPtr->scriptFile != NULL) { - /* - * Can't depend on iPtr->scriptFile to be non-volatile: - * if this command is returned as the result of the script, - * then iPtr->scriptFile will go away. - */ - - Tcl_SetResult(interp, iPtr->scriptFile, TCL_VOLATILE); - } - return TCL_OK; - } else if ((c == 's') && (strncmp(argv[1], "sharedlibextension", - length) == 0) && (length >= 2)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " sharedlibextension\"", (char *) NULL); - return TCL_ERROR; - } -#ifdef TCL_SHLIB_EXT - interp->result = TCL_SHLIB_EXT; -#endif - return TCL_OK; - } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) { - char *value; - - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " tclversion\"", (char *) NULL); - return TCL_ERROR; - } - value = Tcl_GetVar(interp, "tcl_version", - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); - if (value == NULL) { - return TCL_ERROR; - } - interp->result = value; - return TCL_OK; - } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) { - Tcl_HashTable *tablePtr; - char *name; - - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " vars ?pattern?\"", (char *) NULL); - return TCL_ERROR; - } - if (iPtr->varFramePtr == NULL) { - tablePtr = &iPtr->globalTable; - } else { - tablePtr = &iPtr->varFramePtr->varTable; - } - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - if (varPtr->flags & VAR_UNDEFINED) { - continue; - } - name = Tcl_GetHashKey(tablePtr, hPtr); - if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { - continue; - } - Tcl_AppendElement(interp, name); - } - return TCL_OK; - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be args, body, cmdcount, commands, ", - "complete, default, ", - "exists, globals, hostname, level, library, loaded, locals, ", - "nameofexecutable, patchlevel, procs, script, ", - "sharedlibextension, tclversion, or vars", - (char *) NULL); - return TCL_ERROR; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_JoinCmd -- - * - * This procedure is invoked to process the "join" 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_JoinCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - char *joinString; - char **listArgv; - int listArgc, i; - - if (argc == 2) { - joinString = " "; - } else if (argc == 3) { - joinString = argv[2]; - } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " list ?joinString?\"", (char *) NULL); - return TCL_ERROR; - } - - if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) { - return TCL_ERROR; - } - for (i = 0; i < listArgc; i++) { - if (i == 0) { - Tcl_AppendResult(interp, listArgv[0], (char *) NULL); - } else { - Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL); - } - } - ckfree((char *) listArgv); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LindexCmd -- - * - * This procedure is invoked to process the "lindex" 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_LindexCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - char *p, *element, *next; - int index, size, parenthesized, result, returnLast; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " list index\"", (char *) NULL); - return TCL_ERROR; - } - if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { - returnLast = 1; - index = INT_MAX; - } else { - returnLast = 0; - if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { - return TCL_ERROR; - } - } - if (index < 0) { - return TCL_OK; - } - for (p = argv[1] ; index >= 0; index--) { - result = TclFindElement(interp, p, &element, &next, &size, - &parenthesized); - if (result != TCL_OK) { - return result; - } - if ((*next == 0) && returnLast) { - break; - } - p = next; - } - if (size == 0) { - return TCL_OK; - } - if (size >= TCL_RESULT_SIZE) { - interp->result = (char *) ckalloc((unsigned) size+1); - interp->freeProc = TCL_DYNAMIC; - } - if (parenthesized) { - memcpy((VOID *) interp->result, (VOID *) element, (size_t) size); - interp->result[size] = 0; - } else { - TclCopyAndCollapse(size, element, interp->result); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LinsertCmd -- - * - * This procedure is invoked to process the "linsert" 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_LinsertCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - char *p, *element, savedChar; - int i, index, count, result, size; - - if (argc < 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " list index element ?element ...?\"", (char *) NULL); - return TCL_ERROR; - } - if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { - index = INT_MAX; - } else if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Skip over the first "index" elements of the list, then add - * all of those elements to the result. - */ - - size = 0; - element = argv[1]; - for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) { - result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL); - if (result != TCL_OK) { - return result; - } - } - if (*p == 0) { - Tcl_AppendResult(interp, argv[1], (char *) NULL); - } else { - char *end; - - end = element+size; - if (element != argv[1]) { - while ((*end != 0) && !isspace(UCHAR(*end))) { - end++; - } - } - savedChar = *end; - *end = 0; - Tcl_AppendResult(interp, argv[1], (char *) NULL); - *end = savedChar; - } - - /* - * Add the new list elements. - */ - - for (i = 3; i < argc; i++) { - Tcl_AppendElement(interp, argv[i]); - } - - /* - * Append the remainder of the original list. - */ - - if (*p != 0) { - Tcl_AppendResult(interp, " ", p, (char *) NULL); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ListCmd -- - * - * This procedure is invoked to process the "list" 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_ListCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - if (argc >= 2) { - interp->result = Tcl_Merge(argc-1, argv+1); - interp->freeProc = TCL_DYNAMIC; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LlengthCmd -- - * - * This procedure is invoked to process the "llength" 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_LlengthCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int count, result; - char *element, *p; - - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " list\"", (char *) NULL); - return TCL_ERROR; - } - for (count = 0, p = argv[1]; *p != 0 ; count++) { - result = TclFindElement(interp, p, &element, &p, (int *) NULL, - (int *) NULL); - if (result != TCL_OK) { - return result; - } - if (*element == 0) { - break; - } - } - sprintf(interp->result, "%d", count); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LrangeCmd -- - * - * This procedure is invoked to process the "lrange" 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_LrangeCmd( - ClientData notUsed, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int first, last, result; - char *begin, *end, c, *dummy, *next; - int count, firstIsEnd; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " list first last\"", (char *) NULL); - return TCL_ERROR; - } - if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { - firstIsEnd = 1; - first = INT_MAX; - } else { - firstIsEnd = 0; - if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) { - return TCL_ERROR; - } - } - if (first < 0) { - first = 0; - } - if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { - last = INT_MAX; - } else { - if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "expected integer or \"end\" but got \"", - argv[3], "\"", (char *) NULL); - return TCL_ERROR; - } - } - if ((first > last) && !firstIsEnd) { - return TCL_OK; - } - - /* - * Extract a range of fields. - */ - - for (count = 0, begin = argv[1]; count < first; begin = next, count++) { - result = TclFindElement(interp, begin, &dummy, &next, (int *) NULL, - (int *) NULL); - if (result != TCL_OK) { - return result; - } - if (*next == 0) { - if (firstIsEnd) { - first = count; - } else { - begin = next; - } - break; - } - } - for (count = first, end = begin; (count <= last) && (*end != 0); - count++) { - result = TclFindElement(interp, end, &dummy, &end, (int *) NULL, - (int *) NULL); - if (result != TCL_OK) { - return result; - } - } - if (end == begin) { - return TCL_OK; - } - - /* - * Chop off trailing spaces. - */ - - while (isspace(UCHAR(end[-1]))) { - end--; - } - c = *end; - *end = 0; - Tcl_SetResult(interp, begin, TCL_VOLATILE); - *end = c; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LreplaceCmd -- - * - * This procedure is invoked to process the "lreplace" 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_LreplaceCmd( - ClientData notUsed, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - char *p1, *p2, *element, savedChar, *dummy, *next; - int i, first, last, count, result, size, firstIsEnd; - - if (argc < 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " list first last ?element element ...?\"", (char *) NULL); - return TCL_ERROR; - } - if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { - firstIsEnd = 1; - first = INT_MAX; - } else { - firstIsEnd = 0; - if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad index \"", argv[2], - "\": must be integer or \"end\"", (char *) NULL); - return TCL_ERROR; - } - } - if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { - last = INT_MAX; - } else { - if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad index \"", argv[3], - "\": must be integer or \"end\"", (char *) NULL); - return TCL_ERROR; - } - } - if (first < 0) { - first = 0; - } - - /* - * Skip over the elements of the list before "first". - */ - - size = 0; - element = argv[1]; - for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) { - result = TclFindElement(interp, p1, &element, &next, &size, - (int *) NULL); - if (result != TCL_OK) { - return result; - } - if ((*next == 0) && firstIsEnd) { - break; - } - p1 = next; - } - if (*p1 == 0) { - Tcl_AppendResult(interp, "list doesn't contain element ", - argv[2], (char *) NULL); - return TCL_ERROR; - } - - /* - * Skip over the elements of the list up through "last". - */ - - for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) { - result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL, - (int *) NULL); - if (result != TCL_OK) { - return result; - } - } - - /* - * Add the elements before "first" to the result. Drop any terminating - * white space, since a separator will be added below, if needed. - */ - - while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1])))) { - p1--; - } - savedChar = *p1; - *p1 = 0; - Tcl_AppendResult(interp, argv[1], (char *) NULL); - *p1 = savedChar; - - /* - * Add the new list elements. - */ - - for (i = 4; i < argc; i++) { - Tcl_AppendElement(interp, argv[i]); - } - - /* - * Append the remainder of the original list. - */ - - if (*p2 != 0) { - if (*interp->result == 0) { - Tcl_SetResult(interp, p2, TCL_VOLATILE); - } else { - Tcl_AppendResult(interp, " ", p2, (char *) NULL); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LsearchCmd -- - * - * This procedure is invoked to process the "lsearch" 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_LsearchCmd( - ClientData notUsed, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ -#define EXACT 0 -#define GLOB 1 -#define REGEXP 2 - int listArgc; - char **listArgv; - int i, match, mode, index; - - mode = GLOB; - if (argc == 4) { - if (strcmp(argv[1], "-exact") == 0) { - mode = EXACT; - } else if (strcmp(argv[1], "-glob") == 0) { - mode = GLOB; - } else if (strcmp(argv[1], "-regexp") == 0) { - mode = REGEXP; - } else { - Tcl_AppendResult(interp, "bad search mode \"", argv[1], - "\": must be -exact, -glob, or -regexp", (char *) NULL); - return TCL_ERROR; - } - } else if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?mode? list pattern\"", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_SplitList(interp, argv[argc-2], &listArgc, &listArgv) != TCL_OK) { - return TCL_ERROR; - } - index = -1; - for (i = 0; i < listArgc; i++) { - match = 0; - switch (mode) { - case EXACT: - match = (strcmp(listArgv[i], argv[argc-1]) == 0); - break; - case GLOB: - match = Tcl_StringMatch(listArgv[i], argv[argc-1]); - break; - case REGEXP: - match = Tcl_RegExpMatch(interp, listArgv[i], argv[argc-1]); - if (match < 0) { - ckfree((char *) listArgv); - return TCL_ERROR; - } - break; - } - if (match) { - index = i; - break; - } - } - sprintf(interp->result, "%d", index); - ckfree((char *) listArgv); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LsortCmd -- - * - * This procedure is invoked to process the "lsort" 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_LsortCmd( - ClientData notUsed, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int listArgc, i, c; - size_t length; - char **listArgv; - char *command = NULL; /* Initialization needed only to - * prevent compiler warning. */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing?", - " ?-command string? list\"", (char *) NULL); - return TCL_ERROR; - } - - if (sortInterp != NULL) { - interp->result = "can't invoke \"lsort\" recursively"; - return TCL_ERROR; - } - - /* - * Parse arguments to set up the mode for the sort. - */ - - sortInterp = interp; - sortMode = ASCII; - sortIncreasing = 1; - sortCode = TCL_OK; - for (i = 1; i < argc-1; i++) { - length = strlen(argv[i]); - if (length < 2) { - badSwitch: - Tcl_AppendResult(interp, "bad switch \"", argv[i], - "\": must be -ascii, -integer, -real, -increasing", - " -decreasing, or -command", (char *) NULL); - sortCode = TCL_ERROR; - goto done; - } - c = argv[i][1]; - if ((c == 'a') && (strncmp(argv[i], "-ascii", length) == 0)) { - sortMode = ASCII; - } else if ((c == 'c') && (strncmp(argv[i], "-command", length) == 0)) { - if (i == argc-2) { - Tcl_AppendResult(interp, "\"-command\" must be", - " followed by comparison command", (char *) NULL); - sortCode = TCL_ERROR; - goto done; - } - sortMode = COMMAND; - command = argv[i+1]; - i++; - } else if ((c == 'd') - && (strncmp(argv[i], "-decreasing", length) == 0)) { - sortIncreasing = 0; - } else if ((c == 'i') && (length >= 4) - && (strncmp(argv[i], "-increasing", length) == 0)) { - sortIncreasing = 1; - } else if ((c == 'i') && (length >= 4) - && (strncmp(argv[i], "-integer", length) == 0)) { - sortMode = INTEGER; - } else if ((c == 'r') - && (strncmp(argv[i], "-real", length) == 0)) { - sortMode = REAL; - } else { - goto badSwitch; - } - } - if (sortMode == COMMAND) { - Tcl_DStringInit(&sortCmd); - Tcl_DStringAppend(&sortCmd, command, -1); - } - - if (Tcl_SplitList(interp, argv[argc-1], &listArgc, &listArgv) != TCL_OK) { - sortCode = TCL_ERROR; - goto done; - } - qsort((VOID *) listArgv, (size_t) listArgc, sizeof (char *), - SortCompareProc); - if (sortCode == TCL_OK) { - Tcl_ResetResult(interp); - interp->result = Tcl_Merge(listArgc, listArgv); - interp->freeProc = TCL_DYNAMIC; - } - if (sortMode == COMMAND) { - Tcl_DStringFree(&sortCmd); - } - ckfree((char *) listArgv); - - done: - sortInterp = NULL; - return sortCode; -} - -/* - *---------------------------------------------------------------------- - * - * SortCompareProc -- - * - * This procedure is invoked by qsort to determine the proper - * ordering between two elements. - * - * Results: - * < 0 means first is "smaller" than "second", > 0 means "first" - * is larger than "second", and 0 means they should be treated - * as equal. - * - * Side effects: - * None, unless a user-defined comparison command does something - * weird. - * - *---------------------------------------------------------------------- - */ - -static int -SortCompareProc(CONST VOID *first, CONST VOID *second) /* Elements to be compared. */ -{ - int order; - char *firstString = *((char **) first); - char *secondString = *((char **) second); - - order = 0; - if (sortCode != TCL_OK) { - /* - * Once an error has occurred, skip any future comparisons - * so as to preserve the error message in sortInterp->result. - */ - - return order; - } - if (sortMode == ASCII) { - order = strcmp(firstString, secondString); - } else if (sortMode == INTEGER) { - int a, b; - - if ((Tcl_GetInt(sortInterp, firstString, &a) != TCL_OK) - || (Tcl_GetInt(sortInterp, secondString, &b) != TCL_OK)) { - Tcl_AddErrorInfo(sortInterp, - "\n (converting list element from string to integer)"); - sortCode = TCL_ERROR; - return order; - } - if (a > b) { - order = 1; - } else if (b > a) { - order = -1; - } - } else if (sortMode == REAL) { - double a, b; - - if ((Tcl_GetDouble(sortInterp, firstString, &a) != TCL_OK) - || (Tcl_GetDouble(sortInterp, secondString, &b) != TCL_OK)) { - Tcl_AddErrorInfo(sortInterp, - "\n (converting list element from string to real)"); - sortCode = TCL_ERROR; - return order; - } - if (a > b) { - order = 1; - } else if (b > a) { - order = -1; - } - } else { - int oldLength; - char *end; - - /* - * Generate and evaluate a command to determine which string comes - * first. - */ - - oldLength = Tcl_DStringLength(&sortCmd); - Tcl_DStringAppendElement(&sortCmd, firstString); - Tcl_DStringAppendElement(&sortCmd, secondString); - sortCode = Tcl_Eval(sortInterp, Tcl_DStringValue(&sortCmd)); - Tcl_DStringTrunc(&sortCmd, oldLength); - if (sortCode != TCL_OK) { - Tcl_AddErrorInfo(sortInterp, - "\n (user-defined comparison command)"); - return order; - } - - /* - * Parse the result of the command. - */ - - order = strtol(sortInterp->result, &end, 0); - if ((end == sortInterp->result) || (*end != 0)) { - Tcl_ResetResult(sortInterp); - Tcl_AppendResult(sortInterp, - "comparison command returned non-numeric result", - (char *) NULL); - sortCode = TCL_ERROR; - return order; - } - } - if (!sortIncreasing) { - order = -order; - } - return order; -} diff --git a/cde/programs/dtdocbook/tcl/tclCmdMZ.c b/cde/programs/dtdocbook/tcl/tclCmdMZ.c deleted file mode 100644 index 574e7fb3..00000000 --- a/cde/programs/dtdocbook/tcl/tclCmdMZ.c +++ /dev/null @@ -1,2145 +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: tclCmdMZ.c /main/3 1996/10/03 11:07:23 drk $ */ -/* - * tclCmdMZ.c -- - * - * This file contains the top-level command routines for most of - * the Tcl built-in commands whose names begin with the letters - * M to Z. It contains only commands in the generic core (i.e. - * those that don't depend much upon UNIX facilities). - * - * Copyright (c) 1987-1993 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: @(#) tclCmdMZ.c 1.65 96/02/09 14:59:52 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * Structure used to hold information about variable traces: - */ - -typedef struct { - int flags; /* Operations for which Tcl command is - * to be invoked. */ - char *errMsg; /* Error message returned from Tcl command, - * or NULL. Malloc'ed. */ - int length; /* Number of non-NULL chars. in command. */ - char command[4]; /* Space for Tcl command to invoke. Actual - * size will be as large as necessary to - * hold command. This field must be the - * last in the structure, so that it can - * be larger than 4 bytes. */ -} TraceVarInfo; - -/* - * Forward declarations for procedures defined in this file: - */ - -static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *name1, char *name2, - int flags)); - -/* - *---------------------------------------------------------------------- - * - * Tcl_PwdCmd -- - * - * This procedure is invoked to process the "pwd" 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_PwdCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - char *dirName; - - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], "\"", (char *) NULL); - return TCL_ERROR; - } - - dirName = TclGetCwd(interp); - if (dirName == NULL) { - return TCL_ERROR; - } - interp->result = dirName; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RegexpCmd -- - * - * This procedure is invoked to process the "regexp" 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_RegexpCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int noCase = 0; - int indices = 0; - Tcl_RegExp regExpr; - char **argPtr, *string, *pattern, *start, *end; - int match = 0; /* Initialization needed only to - * prevent compiler warning. */ - int i; - Tcl_DString stringDString, patternDString; - - if (argc < 3) { - wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? exp string ?matchVar? ?subMatchVar ", - "subMatchVar ...?\"", (char *) NULL); - return TCL_ERROR; - } - argPtr = argv+1; - argc--; - while ((argc > 0) && (argPtr[0][0] == '-')) { - if (strcmp(argPtr[0], "-indices") == 0) { - indices = 1; - } else if (strcmp(argPtr[0], "-nocase") == 0) { - noCase = 1; - } else if (strcmp(argPtr[0], "--") == 0) { - argPtr++; - argc--; - break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argPtr[0], - "\": must be -indices, -nocase, or --", (char *) NULL); - return TCL_ERROR; - } - argPtr++; - argc--; - } - if (argc < 2) { - goto wrongNumArgs; - } - - /* - * Convert the string and pattern to lower case, if desired, and - * perform the matching operation. - */ - - if (noCase) { - char *p; - - Tcl_DStringInit(&patternDString); - Tcl_DStringAppend(&patternDString, argPtr[0], -1); - pattern = Tcl_DStringValue(&patternDString); - for (p = pattern; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); - } - } - Tcl_DStringInit(&stringDString); - Tcl_DStringAppend(&stringDString, argPtr[1], -1); - string = Tcl_DStringValue(&stringDString); - for (p = string; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); - } - } - } else { - pattern = argPtr[0]; - string = argPtr[1]; - } - regExpr = Tcl_RegExpCompile(interp, pattern); - if (regExpr != NULL) { - match = Tcl_RegExpExec(interp, regExpr, string, string); - } - if (noCase) { - Tcl_DStringFree(&stringDString); - Tcl_DStringFree(&patternDString); - } - if (regExpr == NULL) { - return TCL_ERROR; - } - if (match < 0) { - return TCL_ERROR; - } - if (!match) { - interp->result = "0"; - return TCL_OK; - } - - /* - * If additional variable names have been specified, return - * index information in those variables. - */ - - argc -= 2; - for (i = 0; i < argc; i++) { - char *result, info[50]; - - Tcl_RegExpRange(regExpr, i, &start, &end); - if (start == NULL) { - if (indices) { - result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0); - } else { - result = Tcl_SetVar(interp, argPtr[i+2], "", 0); - } - } else { - if (indices) { - sprintf(info, "%d %d", (int)(start - string), - (int)(end - string - 1)); - result = Tcl_SetVar(interp, argPtr[i+2], info, 0); - } else { - char savedChar, *first, *last; - - first = argPtr[1] + (start - string); - last = argPtr[1] + (end - string); - savedChar = *last; - *last = 0; - result = Tcl_SetVar(interp, argPtr[i+2], first, 0); - *last = savedChar; - } - } - if (result == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - argPtr[i+2], "\"", (char *) NULL); - return TCL_ERROR; - } - } - interp->result = "1"; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RegsubCmd -- - * - * This procedure is invoked to process the "regsub" 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_RegsubCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int noCase = 0, all = 0; - Tcl_RegExp regExpr; - char *string, *pattern, *p, *firstChar, *newValue, **argPtr; - int match, flags, code, numMatches; - char *start, *end, *subStart, *subEnd; - char *src, c; - Tcl_DString stringDString, patternDString; - - if (argc < 5) { - wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? exp string subSpec varName\"", (char *) NULL); - return TCL_ERROR; - } - argPtr = argv+1; - argc--; - while (argPtr[0][0] == '-') { - if (strcmp(argPtr[0], "-nocase") == 0) { - noCase = 1; - } else if (strcmp(argPtr[0], "-all") == 0) { - all = 1; - } else if (strcmp(argPtr[0], "--") == 0) { - argPtr++; - argc--; - break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argPtr[0], - "\": must be -all, -nocase, or --", (char *) NULL); - return TCL_ERROR; - } - argPtr++; - argc--; - } - if (argc != 4) { - goto wrongNumArgs; - } - - /* - * Convert the string and pattern to lower case, if desired. - */ - - if (noCase) { - Tcl_DStringInit(&patternDString); - Tcl_DStringAppend(&patternDString, argPtr[0], -1); - pattern = Tcl_DStringValue(&patternDString); - for (p = pattern; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); - } - } - Tcl_DStringInit(&stringDString); - Tcl_DStringAppend(&stringDString, argPtr[1], -1); - string = Tcl_DStringValue(&stringDString); - for (p = string; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); - } - } - } else { - pattern = argPtr[0]; - string = argPtr[1]; - } - regExpr = Tcl_RegExpCompile(interp, pattern); - if (regExpr == NULL) { - code = TCL_ERROR; - goto done; - } - - /* - * The following loop is to handle multiple matches within the - * same source string; each iteration handles one match and its - * corresponding substitution. If "-all" hasn't been specified - * then the loop body only gets executed once. - */ - - flags = 0; - numMatches = 0; - for (p = string; *p != 0; ) { - match = Tcl_RegExpExec(interp, regExpr, p, string); - if (match < 0) { - code = TCL_ERROR; - goto done; - } - if (!match) { - break; - } - numMatches += 1; - - /* - * Copy the portion of the source string before the match to the - * result variable. - */ - - Tcl_RegExpRange(regExpr, 0, &start, &end); - src = argPtr[1] + (start - string); - c = *src; - *src = 0; - newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), - flags); - *src = c; - flags = TCL_APPEND_VALUE; - if (newValue == NULL) { - cantSet: - Tcl_AppendResult(interp, "couldn't set variable \"", - argPtr[3], "\"", (char *) NULL); - code = TCL_ERROR; - goto done; - } - - /* - * Append the subSpec argument to the variable, making appropriate - * substitutions. This code is a bit hairy because of the backslash - * conventions and because the code saves up ranges of characters in - * subSpec to reduce the number of calls to Tcl_SetVar. - */ - - for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) { - int index; - - if (c == '&') { - index = 0; - } else if (c == '\\') { - c = src[1]; - if ((c >= '0') && (c <= '9')) { - index = c - '0'; - } else if ((c == '\\') || (c == '&')) { - *src = c; - src[1] = 0; - newValue = Tcl_SetVar(interp, argPtr[3], firstChar, - TCL_APPEND_VALUE); - *src = '\\'; - src[1] = c; - if (newValue == NULL) { - goto cantSet; - } - firstChar = src+2; - src++; - continue; - } else { - continue; - } - } else { - continue; - } - if (firstChar != src) { - c = *src; - *src = 0; - newValue = Tcl_SetVar(interp, argPtr[3], firstChar, - TCL_APPEND_VALUE); - *src = c; - if (newValue == NULL) { - goto cantSet; - } - } - Tcl_RegExpRange(regExpr, index, &subStart, &subEnd); - if ((subStart != NULL) && (subEnd != NULL)) { - char *first, *last, saved; - - first = argPtr[1] + (subStart - string); - last = argPtr[1] + (subEnd - string); - saved = *last; - *last = 0; - newValue = Tcl_SetVar(interp, argPtr[3], first, - TCL_APPEND_VALUE); - *last = saved; - if (newValue == NULL) { - goto cantSet; - } - } - if (*src == '\\') { - src++; - } - firstChar = src+1; - } - if (firstChar != src) { - if (Tcl_SetVar(interp, argPtr[3], firstChar, - TCL_APPEND_VALUE) == NULL) { - goto cantSet; - } - } - if (end == p) { - char tmp[2]; - - /* - * Always consume at least one character of the input string - * in order to prevent infinite loops. - */ - - tmp[0] = argPtr[1][p - string]; - tmp[1] = 0; - newValue = Tcl_SetVar(interp, argPtr[3], tmp, flags); - if (newValue == NULL) { - goto cantSet; - } - p = end + 1; - } else { - p = end; - } - if (!all) { - break; - } - } - - /* - * Copy the portion of the source string after the last match to the - * result variable. - */ - - if ((*p != 0) || (numMatches == 0)) { - if (Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), - flags) == NULL) { - goto cantSet; - } - } - sprintf(interp->result, "%d", numMatches); - code = TCL_OK; - - done: - if (noCase) { - Tcl_DStringFree(&stringDString); - Tcl_DStringFree(&patternDString); - } - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RenameCmd -- - * - * This procedure is invoked to process the "rename" 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_RenameCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Command *cmdPtr; - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - int new; - char *srcName, *dstName; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " oldName newName\"", (char *) NULL); - return TCL_ERROR; - } - if (argv[2][0] == '\0') { - if (Tcl_DeleteCommand(interp, argv[1]) != 0) { - Tcl_AppendResult(interp, "can't delete \"", argv[1], - "\": command doesn't exist", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; - } - - srcName = argv[1]; - dstName = argv[2]; - hPtr = Tcl_FindHashEntry(&iPtr->commandTable, dstName); - if (hPtr != NULL) { - Tcl_AppendResult(interp, "can't rename to \"", argv[2], - "\": command already exists", (char *) NULL); - return TCL_ERROR; - } - - /* - * The code below was added in 11/95 to preserve backwards compatibility - * when "tkerror" was renamed "bgerror": we guarantee that the hash - * table entries for both commands refer to a single shared Command - * structure. This code should eventually become unnecessary. - */ - - if ((srcName[0] == 't') && (strcmp(srcName, "tkerror") == 0)) { - srcName = "bgerror"; - } - dstName = argv[2]; - if ((dstName[0] == 't') && (strcmp(dstName, "tkerror") == 0)) { - dstName = "bgerror"; - } - - hPtr = Tcl_FindHashEntry(&iPtr->commandTable, srcName); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "can't rename \"", argv[1], - "\": command doesn't exist", (char *) NULL); - return TCL_ERROR; - } - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - - /* - * Prevent formation of alias loops through renaming. - */ - - if (TclPreventAliasLoop(interp, interp, dstName, cmdPtr->proc, - cmdPtr->clientData) != TCL_OK) { - return TCL_ERROR; - } - - Tcl_DeleteHashEntry(hPtr); - hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, dstName, &new); - Tcl_SetHashValue(hPtr, cmdPtr); - cmdPtr->hPtr = hPtr; - - /* - * The code below provides more backwards compatibility for the - * "tkerror" => "bgerror" renaming. As with the other compatibility - * code above, it should eventually be removed. - */ - - if ((dstName[0] == 'b') && (strcmp(dstName, "bgerror") == 0)) { - /* - * The destination command is "bgerror"; create a "tkerror" - * command that shares the same Command structure. - */ - - hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new); - Tcl_SetHashValue(hPtr, cmdPtr); - } - if ((srcName[0] == 'b') && (strcmp(srcName, "bgerror") == 0)) { - /* - * The source command is "bgerror": delete the hash table - * entry for "tkerror" if it exists. - */ - - Tcl_DeleteHashEntry(Tcl_FindHashEntry(&iPtr->commandTable, "tkerror")); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ReturnCmd -- - * - * This procedure is invoked to process the "return" 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_ReturnCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Interp *iPtr = (Interp *) interp; - int c, code; - - if (iPtr->errorInfo != NULL) { - ckfree(iPtr->errorInfo); - iPtr->errorInfo = NULL; - } - if (iPtr->errorCode != NULL) { - ckfree(iPtr->errorCode); - iPtr->errorCode = NULL; - } - code = TCL_OK; - for (argv++, argc--; argc > 1; argv += 2, argc -= 2) { - if (strcmp(argv[0], "-code") == 0) { - c = argv[1][0]; - if ((c == 'o') && (strcmp(argv[1], "ok") == 0)) { - code = TCL_OK; - } else if ((c == 'e') && (strcmp(argv[1], "error") == 0)) { - code = TCL_ERROR; - } else if ((c == 'r') && (strcmp(argv[1], "return") == 0)) { - code = TCL_RETURN; - } else if ((c == 'b') && (strcmp(argv[1], "break") == 0)) { - code = TCL_BREAK; - } else if ((c == 'c') && (strcmp(argv[1], "continue") == 0)) { - code = TCL_CONTINUE; - } else if (Tcl_GetInt(interp, argv[1], &code) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad completion code \"", - argv[1], "\": must be ok, error, return, break, ", - "continue, or an integer", (char *) NULL); - return TCL_ERROR; - } - } else if (strcmp(argv[0], "-errorinfo") == 0) { - iPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(argv[1]) + 1)); - strcpy(iPtr->errorInfo, argv[1]); - } else if (strcmp(argv[0], "-errorcode") == 0) { - iPtr->errorCode = (char *) ckalloc((unsigned) (strlen(argv[1]) + 1)); - strcpy(iPtr->errorCode, argv[1]); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[0], - ": must be -code, -errorcode, or -errorinfo", - (char *) NULL); - return TCL_ERROR; - } - } - if (argc == 1) { - Tcl_SetResult(interp, argv[0], TCL_VOLATILE); - } - iPtr->returnCode = code; - return TCL_RETURN; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ScanCmd -- - * - * This procedure is invoked to process the "scan" 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_ScanCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ -# define MAX_FIELDS 20 - typedef struct { - char fmt; /* Format for field. */ - int size; /* How many bytes to allow for - * field. */ - char *location; /* Where field will be stored. */ - } Field; - Field fields[MAX_FIELDS]; /* Info about all the fields in the - * format string. */ - Field *curField; - int numFields = 0; /* Number of fields actually - * specified. */ - int suppress; /* Current field is assignment- - * suppressed. */ - int totalSize = 0; /* Number of bytes needed to store - * all results combined. */ - char *results; /* Where scanned output goes. - * Malloced; NULL means not allocated - * yet. */ - int numScanned; /* sscanf's result. */ - char *fmt; - int i, widthSpecified, length, code; - - /* - * The variables below are used to hold a copy of the format - * string, so that we can replace format specifiers like "%f" - * and "%F" with specifiers like "%lf" - */ - -# define STATIC_SIZE 5 - char copyBuf[STATIC_SIZE], *fmtCopy; - char *dst; - - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " string format ?varName varName ...?\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * This procedure operates in four stages: - * 1. Scan the format string, collecting information about each field. - * 2. Allocate an array to hold all of the scanned fields. - * 3. Call sscanf to do all the dirty work, and have it store the - * parsed fields in the array. - * 4. Pick off the fields from the array and assign them to variables. - */ - - code = TCL_OK; - results = NULL; - length = strlen(argv[2]) * 2 + 1; - if (length < STATIC_SIZE) { - fmtCopy = copyBuf; - } else { - fmtCopy = (char *) ckalloc((unsigned) length); - } - dst = fmtCopy; - for (fmt = argv[2]; *fmt != 0; fmt++) { - *dst = *fmt; - dst++; - if (*fmt != '%') { - continue; - } - fmt++; - if (*fmt == '%') { - *dst = *fmt; - dst++; - continue; - } - if (*fmt == '*') { - suppress = 1; - *dst = *fmt; - dst++; - fmt++; - } else { - suppress = 0; - } - widthSpecified = 0; - while (isdigit(UCHAR(*fmt))) { - widthSpecified = 1; - *dst = *fmt; - dst++; - fmt++; - } - if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) { - fmt++; - } - *dst = *fmt; - dst++; - if (suppress) { - continue; - } - if (numFields == MAX_FIELDS) { - interp->result = "too many fields to scan"; - code = TCL_ERROR; - goto done; - } - curField = &fields[numFields]; - numFields++; - switch (*fmt) { - case 'd': - case 'i': - case 'o': - case 'x': - curField->fmt = 'd'; - curField->size = sizeof(int); - break; - - case 'u': - curField->fmt = 'u'; - curField->size = sizeof(int); - break; - - case 's': - curField->fmt = 's'; - curField->size = strlen(argv[1]) + 1; - break; - - case 'c': - if (widthSpecified) { - interp->result = - "field width may not be specified in %c conversion"; - code = TCL_ERROR; - goto done; - } - curField->fmt = 'c'; - curField->size = sizeof(int); - break; - - case 'e': - case 'f': - case 'g': - dst[-1] = 'l'; - dst[0] = 'f'; - dst++; - curField->fmt = 'f'; - curField->size = sizeof(double); - break; - - case '[': - curField->fmt = 's'; - curField->size = strlen(argv[1]) + 1; - do { - fmt++; - if (*fmt == 0) { - interp->result = "unmatched [ in format string"; - code = TCL_ERROR; - goto done; - } - *dst = *fmt; - dst++; - } while (*fmt != ']'); - break; - - default: - sprintf(interp->result, "bad scan conversion character \"%c\"", - *fmt); - code = TCL_ERROR; - goto done; - } - curField->size = TCL_ALIGN(curField->size); - totalSize += curField->size; - } - *dst = 0; - - if (numFields != (argc-3)) { - interp->result = - "different numbers of variable names and field specifiers"; - code = TCL_ERROR; - goto done; - } - - /* - * Step 2: - */ - - results = (char *) ckalloc((unsigned) totalSize); - for (i = 0, totalSize = 0, curField = fields; - i < numFields; i++, curField++) { - curField->location = results + totalSize; - totalSize += curField->size; - } - - /* - * Fill in the remaining fields with NULL; the only purpose of - * this is to keep some memory analyzers, like Purify, from - * complaining. - */ - - for ( ; i < MAX_FIELDS; i++, curField++) { - curField->location = NULL; - } - - /* - * Step 3: - */ - - numScanned = sscanf(argv[1], fmtCopy, - fields[0].location, fields[1].location, fields[2].location, - fields[3].location, fields[4].location, fields[5].location, - fields[6].location, fields[7].location, fields[8].location, - fields[9].location, fields[10].location, fields[11].location, - fields[12].location, fields[13].location, fields[14].location, - fields[15].location, fields[16].location, fields[17].location, - fields[18].location, fields[19].location); - - /* - * Step 4: - */ - - if (numScanned < numFields) { - numFields = numScanned; - } - for (i = 0, curField = fields; i < numFields; i++, curField++) { - switch (curField->fmt) { - char string[TCL_DOUBLE_SPACE]; - - case 'd': - sprintf(string, "%d", *((int *) curField->location)); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - storeError: - Tcl_AppendResult(interp, - "couldn't set variable \"", argv[i+3], "\"", - (char *) NULL); - code = TCL_ERROR; - goto done; - } - break; - - case 'u': - sprintf(string, "%u", *((int *) curField->location)); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; - } - break; - - case 'c': - sprintf(string, "%d", *((char *) curField->location) & 0xff); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; - } - break; - - case 's': - if (Tcl_SetVar(interp, argv[i+3], curField->location, 0) - == NULL) { - goto storeError; - } - break; - - case 'f': - Tcl_PrintDouble(interp, *((double *) curField->location), - string); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; - } - break; - } - } - sprintf(interp->result, "%d", numScanned); - done: - if (results != NULL) { - ckfree(results); - } - if (fmtCopy != copyBuf) { - ckfree(fmtCopy); - } - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SourceCmd -- - * - * This procedure is invoked to process the "source" 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_SourceCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " fileName\"", (char *) NULL); - return TCL_ERROR; - } - return Tcl_EvalFile(interp, argv[1]); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SplitCmd -- - * - * This procedure is invoked to process the "split" 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_SplitCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - char *splitChars; - char *p, *p2; - char *elementStart; - - if (argc == 2) { - splitChars = " \n\t\r"; - } else if (argc == 3) { - splitChars = argv[2]; - } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " string ?splitChars?\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * Handle the special case of splitting on every character. - */ - - if (*splitChars == 0) { - char string[2]; - string[1] = 0; - for (p = argv[1]; *p != 0; p++) { - string[0] = *p; - Tcl_AppendElement(interp, string); - } - return TCL_OK; - } - - /* - * Normal case: split on any of a given set of characters. - * Discard instances of the split characters. - */ - - for (p = elementStart = argv[1]; *p != 0; p++) { - char c = *p; - for (p2 = splitChars; *p2 != 0; p2++) { - if (*p2 == c) { - *p = 0; - Tcl_AppendElement(interp, elementStart); - *p = c; - elementStart = p+1; - break; - } - } - } - if (p != argv[1]) { - Tcl_AppendElement(interp, elementStart); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_StringCmd -- - * - * This procedure is invoked to process the "string" 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_StringCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - size_t length; - char *p; - int match, c, first; - int left = 0, right = 0; - - 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 == 'c') && (strncmp(argv[1], "compare", length) == 0)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " compare string1 string2\"", (char *) NULL); - return TCL_ERROR; - } - match = strcmp(argv[2], argv[3]); - if (match > 0) { - interp->result = "1"; - } else if (match < 0) { - interp->result = "-1"; - } else { - interp->result = "0"; - } - return TCL_OK; - } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " first string1 string2\"", (char *) NULL); - return TCL_ERROR; - } - first = 1; - - firstLast: - match = -1; - c = *argv[2]; - length = strlen(argv[2]); - for (p = argv[3]; *p != 0; p++) { - if (*p != c) { - continue; - } - if (strncmp(argv[2], p, length) == 0) { - match = p-argv[3]; - if (first) { - break; - } - } - } - sprintf(interp->result, "%d", match); - return TCL_OK; - } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) { - int index; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " index string charIndex\"", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { - return TCL_ERROR; - } - if ((index >= 0) && (index < (int) strlen(argv[2]))) { - interp->result[0] = argv[2][index]; - interp->result[1] = 0; - } - return TCL_OK; - } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0) - && (length >= 2)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " last string1 string2\"", (char *) NULL); - return TCL_ERROR; - } - first = 0; - goto firstLast; - } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0) - && (length >= 2)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " length string\"", (char *) NULL); - return TCL_ERROR; - } - sprintf(interp->result, "%ld", (long)strlen(argv[2])); - return TCL_OK; - } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " match pattern string\"", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_StringMatch(argv[3], argv[2]) != 0) { - interp->result = "1"; - } else { - interp->result = "0"; - } - return TCL_OK; - } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) { - int first, last, stringLength; - - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " range string first last\"", (char *) NULL); - return TCL_ERROR; - } - stringLength = strlen(argv[2]); - if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) { - return TCL_ERROR; - } - if ((*argv[4] == 'e') - && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) { - last = stringLength-1; - } else { - if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "expected integer or \"end\" but got \"", - argv[4], "\"", (char *) NULL); - return TCL_ERROR; - } - } - if (first < 0) { - first = 0; - } - if (last >= stringLength) { - last = stringLength-1; - } - if (last >= first) { - char saved, *p; - - p = argv[2] + last + 1; - saved = *p; - *p = 0; - Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE); - *p = saved; - } - return TCL_OK; - } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0) - && (length >= 3)) { - char *p; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " tolower string\"", (char *) NULL); - return TCL_ERROR; - } - Tcl_SetResult(interp, argv[2], TCL_VOLATILE); - for (p = interp->result; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); - } - } - return TCL_OK; - } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0) - && (length >= 3)) { - char *p; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " toupper string\"", (char *) NULL); - return TCL_ERROR; - } - Tcl_SetResult(interp, argv[2], TCL_VOLATILE); - for (p = interp->result; *p != 0; p++) { - if (islower(UCHAR(*p))) { - *p = (char) toupper(UCHAR(*p)); - } - } - return TCL_OK; - } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0) - && (length == 4)) { - char *trimChars; - char *p, *checkPtr; - - left = right = 1; - - trim: - if (argc == 4) { - trimChars = argv[3]; - } else if (argc == 3) { - trimChars = " \t\n\r"; - } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " string ?chars?\"", (char *) NULL); - return TCL_ERROR; - } - p = argv[2]; - if (left) { - for (c = *p; c != 0; p++, c = *p) { - for (checkPtr = trimChars; *checkPtr != c; checkPtr++) { - if (*checkPtr == 0) { - goto doneLeft; - } - } - } - } - doneLeft: - Tcl_SetResult(interp, p, TCL_VOLATILE); - if (right) { - char *donePtr; - - p = interp->result + strlen(interp->result) - 1; - donePtr = &interp->result[-1]; - for (c = *p; p != donePtr; p--, c = *p) { - for (checkPtr = trimChars; *checkPtr != c; checkPtr++) { - if (*checkPtr == 0) { - goto doneRight; - } - } - } - doneRight: - p[1] = 0; - } - return TCL_OK; - } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0) - && (length > 4)) { - left = 1; - argv[1] = "trimleft"; - goto trim; - } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0) - && (length > 4)) { - right = 1; - argv[1] = "trimright"; - goto trim; - } else if ((c == 'w') && (strncmp(argv[1], "wordend", length) == 0) - && (length > 4)) { - int length, index, cur; - char *string; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " string index\"", (char *) NULL); - return TCL_ERROR; - } - string = argv[2]; - if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { - return TCL_ERROR; - } - length = strlen(argv[2]); - if (index < 0) { - index = 0; - } - if (index >= length) { - cur = length; - goto wordendDone; - } - for (cur = index ; cur < length; cur++) { - c = UCHAR(string[cur]); - if (!isalnum(c) && (c != '_')) { - break; - } - } - if (cur == index) { - cur = index+1; - } - wordendDone: - sprintf(interp->result, "%d", cur); - return TCL_OK; - } else if ((c == 'w') && (strncmp(argv[1], "wordstart", length) == 0) - && (length > 4)) { - int length, index, cur; - char *string; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " string index\"", (char *) NULL); - return TCL_ERROR; - } - string = argv[2]; - if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { - return TCL_ERROR; - } - length = strlen(argv[2]); - if (index >= length) { - index = length-1; - } - if (index <= 0) { - cur = 0; - goto wordstartDone; - } - for (cur = index ; cur >= 0; cur--) { - c = UCHAR(string[cur]); - if (!isalnum(c) && (c != '_')) { - break; - } - } - if (cur != index) { - cur += 1; - } - wordstartDone: - sprintf(interp->result, "%d", cur); - return TCL_OK; - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be compare, first, index, last, length, match, ", - "range, tolower, toupper, trim, trimleft, trimright, ", - "wordend, or wordstart", (char *) NULL); - return TCL_ERROR; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SubstCmd -- - * - * This procedure is invoked to process the "subst" Tcl command. - * See the user documentation for details on what it does. This - * command is an almost direct copy of an implementation by - * Andrew Payne. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_SubstCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Interp *iPtr = (Interp *) interp; - Tcl_DString result; - char *p, *old, *value; - int code, count, doVars, doCmds, doBackslashes, i; - size_t length; - char c; - - /* - * Parse command-line options. - */ - - doVars = doCmds = doBackslashes = 1; - for (i = 1; i < (argc-1); i++) { - p = argv[i]; - if (*p != '-') { - break; - } - length = strlen(p); - if (length < 4) { - badSwitch: - Tcl_AppendResult(interp, "bad switch \"", p, - "\": must be -nobackslashes, -nocommands, ", - "or -novariables", (char *) NULL); - return TCL_ERROR; - } - if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) { - doBackslashes = 0; - } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) { - doCmds = 0; - } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) { - doVars = 0; - } else { - goto badSwitch; - } - } - if (i != (argc-1)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?-nobackslashes? ?-nocommands? ?-novariables? string\"", - (char *) NULL); - return TCL_ERROR; - } - - /* - * Scan through the string one character at a time, performing - * command, variable, and backslash substitutions. - */ - - Tcl_DStringInit(&result); - old = p = argv[i]; - while (*p != 0) { - switch (*p) { - case '\\': - if (doBackslashes) { - if (p != old) { - Tcl_DStringAppend(&result, old, p-old); - } - c = Tcl_Backslash(p, &count); - Tcl_DStringAppend(&result, &c, 1); - p += count; - old = p; - } else { - p++; - } - break; - - case '$': - if (doVars) { - if (p != old) { - Tcl_DStringAppend(&result, old, p-old); - } - value = Tcl_ParseVar(interp, p, &p); - if (value == NULL) { - Tcl_DStringFree(&result); - return TCL_ERROR; - } - Tcl_DStringAppend(&result, value, -1); - old = p; - } else { - p++; - } - break; - - case '[': - if (doCmds) { - if (p != old) { - Tcl_DStringAppend(&result, old, p-old); - } - iPtr->evalFlags = TCL_BRACKET_TERM; - code = Tcl_Eval(interp, p+1); - if (code == TCL_ERROR) { - Tcl_DStringFree(&result); - return code; - } - old = p = iPtr->termPtr+1; - Tcl_DStringAppend(&result, iPtr->result, -1); - Tcl_ResetResult(interp); - } else { - p++; - } - break; - - default: - p++; - break; - } - } - if (p != old) { - Tcl_DStringAppend(&result, old, p-old); - } - Tcl_DStringResult(interp, &result); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SwitchCmd -- - * - * This procedure is invoked to process the "switch" 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_SwitchCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ -#define EXACT 0 -#define GLOB 1 -#define REGEXP 2 - int i, code, mode, matched; - int body; - char *string; - int switchArgc, splitArgs; - char **switchArgv; - - switchArgc = argc-1; - switchArgv = argv+1; - mode = EXACT; - while ((switchArgc > 0) && (*switchArgv[0] == '-')) { - if (strcmp(*switchArgv, "-exact") == 0) { - mode = EXACT; - } else if (strcmp(*switchArgv, "-glob") == 0) { - mode = GLOB; - } else if (strcmp(*switchArgv, "-regexp") == 0) { - mode = REGEXP; - } else if (strcmp(*switchArgv, "--") == 0) { - switchArgc--; - switchArgv++; - break; - } else { - Tcl_AppendResult(interp, "bad option \"", switchArgv[0], - "\": should be -exact, -glob, -regexp, or --", - (char *) NULL); - return TCL_ERROR; - } - switchArgc--; - switchArgv++; - } - if (switchArgc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ?switches? string pattern body ... ?default body?\"", - (char *) NULL); - return TCL_ERROR; - } - string = *switchArgv; - switchArgc--; - switchArgv++; - - /* - * If all of the pattern/command pairs are lumped into a single - * argument, split them out again. - */ - - splitArgs = 0; - if (switchArgc == 1) { - code = Tcl_SplitList(interp, switchArgv[0], &switchArgc, &switchArgv); - if (code != TCL_OK) { - return code; - } - splitArgs = 1; - } - - for (i = 0; i < switchArgc; i += 2) { - if (i == (switchArgc-1)) { - interp->result = "extra switch pattern with no body"; - code = TCL_ERROR; - goto cleanup; - } - - /* - * See if the pattern matches the string. - */ - - matched = 0; - if ((*switchArgv[i] == 'd') && (i == switchArgc-2) - && (strcmp(switchArgv[i], "default") == 0)) { - matched = 1; - } else { - switch (mode) { - case EXACT: - matched = (strcmp(string, switchArgv[i]) == 0); - break; - case GLOB: - matched = Tcl_StringMatch(string, switchArgv[i]); - break; - case REGEXP: - matched = Tcl_RegExpMatch(interp, string, switchArgv[i]); - if (matched < 0) { - code = TCL_ERROR; - goto cleanup; - } - break; - } - } - if (!matched) { - continue; - } - - /* - * We've got a match. Find a body to execute, skipping bodies - * that are "-". - */ - - for (body = i+1; ; body += 2) { - if (body >= switchArgc) { - Tcl_AppendResult(interp, "no body specified for pattern \"", - switchArgv[i], "\"", (char *) NULL); - code = TCL_ERROR; - goto cleanup; - } - if ((switchArgv[body][0] != '-') || (switchArgv[body][1] != 0)) { - break; - } - } - code = Tcl_Eval(interp, switchArgv[body]); - if (code == TCL_ERROR) { - char msg[100]; - sprintf(msg, "\n (\"%.50s\" arm line %d)", switchArgv[i], - interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - goto cleanup; - } - - /* - * Nothing matched: return nothing. - */ - - code = TCL_OK; - - cleanup: - if (splitArgs) { - ckfree((char *) switchArgv); - } - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_TimeCmd -- - * - * This procedure is invoked to process the "time" 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_TimeCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int count, i, result; - double timePer; - Tcl_Time start, stop; - - if (argc == 2) { - count = 1; - } else if (argc == 3) { - if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { - return TCL_ERROR; - } - } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " command ?count?\"", (char *) NULL); - return TCL_ERROR; - } - TclGetTime(&start); - for (i = count ; i > 0; i--) { - result = Tcl_Eval(interp, argv[1]); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"time\" body line %d)", - interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - return result; - } - } - TclGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - Tcl_ResetResult(interp); - sprintf(interp->result, "%.0f microseconds per iteration", - (count <= 0) ? 0 : timePer/count); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_TraceCmd -- - * - * This procedure is invoked to process the "trace" 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_TraceCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int c; - size_t length; - - if (argc < 2) { - Tcl_AppendResult(interp, "too few args: should be \"", - argv[0], " option [arg arg ...]\"", (char *) NULL); - return TCL_ERROR; - } - c = argv[1][1]; - length = strlen(argv[1]); - if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0) - && (length >= 2)) { - char *p; - int flags, length; - TraceVarInfo *tvarPtr; - - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " variable name ops command\"", (char *) NULL); - return TCL_ERROR; - } - - flags = 0; - for (p = argv[3] ; *p != 0; p++) { - if (*p == 'r') { - flags |= TCL_TRACE_READS; - } else if (*p == 'w') { - flags |= TCL_TRACE_WRITES; - } else if (*p == 'u') { - flags |= TCL_TRACE_UNSETS; - } else { - goto badOps; - } - } - if (flags == 0) { - goto badOps; - } - - length = strlen(argv[4]); - tvarPtr = (TraceVarInfo *) ckalloc((unsigned) - (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); - tvarPtr->flags = flags; - tvarPtr->errMsg = NULL; - tvarPtr->length = length; - flags |= TCL_TRACE_UNSETS; - strcpy(tvarPtr->command, argv[4]); - if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc, - (ClientData) tvarPtr) != TCL_OK) { - ckfree((char *) tvarPtr); - return TCL_ERROR; - } - } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length) - && (length >= 2)) == 0) { - char *p; - int flags, length; - TraceVarInfo *tvarPtr; - ClientData clientData; - - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " vdelete name ops command\"", (char *) NULL); - return TCL_ERROR; - } - - flags = 0; - for (p = argv[3] ; *p != 0; p++) { - if (*p == 'r') { - flags |= TCL_TRACE_READS; - } else if (*p == 'w') { - flags |= TCL_TRACE_WRITES; - } else if (*p == 'u') { - flags |= TCL_TRACE_UNSETS; - } else { - goto badOps; - } - } - if (flags == 0) { - goto badOps; - } - - /* - * Search through all of our traces on this variable to - * see if there's one with the given command. If so, then - * delete the first one that matches. - */ - - length = strlen(argv[4]); - clientData = 0; - while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, - TraceVarProc, clientData)) != 0) { - tvarPtr = (TraceVarInfo *) clientData; - if ((tvarPtr->length == length) && (tvarPtr->flags == flags) - && (strncmp(argv[4], tvarPtr->command, - (size_t) length) == 0)) { - Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS, - TraceVarProc, clientData); - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); - } - ckfree((char *) tvarPtr); - break; - } - } - } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0) - && (length >= 2)) { - ClientData clientData; - char ops[4], *p; - char *prefix = "{"; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " vinfo name\"", (char *) NULL); - return TCL_ERROR; - } - clientData = 0; - while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, - TraceVarProc, clientData)) != 0) { - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; - p = ops; - if (tvarPtr->flags & TCL_TRACE_READS) { - *p = 'r'; - p++; - } - if (tvarPtr->flags & TCL_TRACE_WRITES) { - *p = 'w'; - p++; - } - if (tvarPtr->flags & TCL_TRACE_UNSETS) { - *p = 'u'; - p++; - } - *p = '\0'; - Tcl_AppendResult(interp, prefix, (char *) NULL); - Tcl_AppendElement(interp, ops); - Tcl_AppendElement(interp, tvarPtr->command); - Tcl_AppendResult(interp, "}", (char *) NULL); - prefix = " {"; - } - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be variable, vdelete, or vinfo", - (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; - - badOps: - Tcl_AppendResult(interp, "bad operations \"", argv[3], - "\": should be one or more of rwu", (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TraceVarProc -- - * - * This procedure is called to handle variable accesses that have - * been traced using the "trace" command. - * - * Results: - * Normally returns NULL. If the trace command returns an error, - * then this procedure returns an error string. - * - * Side effects: - * Depends on the command associated with the trace. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static char * -TraceVarProc( - ClientData clientData, /* Information about the variable trace. */ - Tcl_Interp *interp, /* Interpreter containing variable. */ - char *name1, /* Name of variable or array. */ - char *name2, /* Name of element within array; NULL means - * scalar variable is being referenced. */ - int flags /* OR-ed bits giving operation and other - * information. */ -) -{ - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; - char *result; - int code; - Interp dummy; - Tcl_DString cmd; - - result = NULL; - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); - tvarPtr->errMsg = NULL; - } - if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { - - /* - * Generate a command to execute by appending list elements - * for the two variable names and the operation. The five - * extra characters are for three space, the opcode character, - * and the terminating null. - */ - - if (name2 == NULL) { - name2 = ""; - } - Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); - Tcl_DStringAppendElement(&cmd, name1); - Tcl_DStringAppendElement(&cmd, name2); - if (flags & TCL_TRACE_READS) { - Tcl_DStringAppend(&cmd, " r", 2); - } else if (flags & TCL_TRACE_WRITES) { - Tcl_DStringAppend(&cmd, " w", 2); - } else if (flags & TCL_TRACE_UNSETS) { - Tcl_DStringAppend(&cmd, " u", 2); - } - - /* - * Execute the command. Be careful to save and restore the - * result from the interpreter used for the command. - */ - - if (interp->freeProc == 0) { - dummy.freeProc = (Tcl_FreeProc *) 0; - dummy.result = ""; - Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE); - } else { - dummy.freeProc = interp->freeProc; - dummy.result = interp->result; - interp->freeProc = (Tcl_FreeProc *) 0; - } - code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); - Tcl_DStringFree(&cmd); - if (code != TCL_OK) { - tvarPtr->errMsg = (char *) ckalloc((unsigned) (strlen(interp->result) + 1)); - strcpy(tvarPtr->errMsg, interp->result); - result = tvarPtr->errMsg; - Tcl_ResetResult(interp); /* Must clear error state. */ - } - Tcl_SetResult(interp, dummy.result, - (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc); - } - if (flags & TCL_TRACE_DESTROYED) { - result = NULL; - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); - } - ckfree((char *) tvarPtr); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_WhileCmd -- - * - * This procedure is invoked to process the "while" 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_WhileCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int result, value; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " test command\"", (char *) NULL); - return TCL_ERROR; - } - - while (1) { - result = Tcl_ExprBoolean(interp, argv[1], &value); - if (result != TCL_OK) { - return result; - } - if (!value) { - break; - } - result = Tcl_Eval(interp, argv[2]); - if ((result != TCL_OK) && (result != TCL_CONTINUE)) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"while\" body line %d)", - interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - break; - } - } - if (result == TCL_BREAK) { - result = TCL_OK; - } - if (result == TCL_OK) { - Tcl_ResetResult(interp); - } - return result; -} diff --git a/cde/programs/dtdocbook/tcl/tclDate.c b/cde/programs/dtdocbook/tcl/tclDate.c deleted file mode 100644 index 17cee4b1..00000000 --- a/cde/programs/dtdocbook/tcl/tclDate.c +++ /dev/null @@ -1,1617 +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: tclDate.c /main/2 1996/08/08 14:43:30 cde-hp $ */ -/* - * tclGetdate.c -- - * - * This file is generated from a yacc grammar defined in - * the file tclGetdate.y - * - * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. - * 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. - * - * @(#) tclDate.c 1.24 96/04/18 16:53:56 - */ - -#include "tclInt.h" -#include "tclPort.h" - -#ifdef MAC_TCL -# define EPOCH 1904 -# define START_OF_TIME 1904 -# define END_OF_TIME 2039 -#else -# define EPOCH 1970 -# define START_OF_TIME 1902 -# define END_OF_TIME 2037 - -extern struct tm *localtime(); -#endif - -#define HOUR(x) ((int) (60 * x)) -#define SECSPERDAY (24L * 60L * 60L) - - -/* - * An entry in the lexical lookup table. - */ -typedef struct _TABLE { - char *name; - int type; - time_t value; -} TABLE; - - -/* - * Daylight-savings mode: on, off, or not yet known. - */ -typedef enum _DSTMODE { - DSTon, DSToff, DSTmaybe -} DSTMODE; - -/* - * Meridian: am, pm, or 24-hour style. - */ -typedef enum _MERIDIAN { - MERam, MERpm, MER24 -} MERIDIAN; - - -/* - * Global variables. We could get rid of most of these by using a good - * union as the yacc stack. (This routine was originally written before - * yacc had the %union construct.) Maybe someday; right now we only use - * the %union very rarely. - */ -static char *TclDateInput; -static DSTMODE TclDateDSTmode; -static time_t TclDateDayOrdinal; -static time_t TclDateDayNumber; -static int TclDateHaveDate; -static int TclDateHaveDay; -static int TclDateHaveRel; -static int TclDateHaveTime; -static int TclDateHaveZone; -static time_t TclDateTimezone; -static time_t TclDateDay; -static time_t TclDateHour; -static time_t TclDateMinutes; -static time_t TclDateMonth; -static time_t TclDateSeconds; -static time_t TclDateYear; -static MERIDIAN TclDateMeridian; -static time_t TclDateRelMonth; -static time_t TclDateRelSeconds; - - -/* - * Prototypes of internal functions. - */ -static void -TclDateerror _ANSI_ARGS_((char *s)); - -static time_t -ToSeconds _ANSI_ARGS_((time_t Hours, - time_t Minutes, - time_t Seconds, - MERIDIAN Meridian)); - -static int -Convert _ANSI_ARGS_((time_t Month, - time_t Day, - time_t Year, - time_t Hours, - time_t Minutes, - time_t Seconds, - MERIDIAN Meridia, - DSTMODE DSTmode, - time_t *TimePtr)); - -static time_t -DSTcorrect _ANSI_ARGS_((time_t Start, - time_t Future)); - -static time_t -RelativeDate _ANSI_ARGS_((time_t Start, - time_t DayOrdinal, - time_t DayNumber)); - -static int -RelativeMonth _ANSI_ARGS_((time_t Start, - time_t RelMonth, - time_t *TimePtr)); -static int -LookupWord _ANSI_ARGS_((char *buff)); - -static int -TclDatelex _ANSI_ARGS_((void)); - -int -TclDateparse _ANSI_ARGS_((void)); -typedef union -#ifdef __cplusplus - YYSTYPE -#endif - { - time_t Number; - enum _MERIDIAN Meridian; -} YYSTYPE; -# define tAGO 257 -# define tDAY 258 -# define tDAYZONE 259 -# define tID 260 -# define tMERIDIAN 261 -# define tMINUTE_UNIT 262 -# define tMONTH 263 -# define tMONTH_UNIT 264 -# define tSEC_UNIT 265 -# define tSNUMBER 266 -# define tUNUMBER 267 -# define tZONE 268 -# define tEPOCH 269 -# define tDST 270 - - - -#ifdef __cplusplus - -#ifndef TclDateerror - void TclDateerror(const char *); -#endif - -#ifndef TclDatelex -#ifdef __EXTERN_C__ - extern "C" { int TclDatelex(void); } -#else - int TclDatelex(void); -#endif -#endif - int TclDateparse(void); - -#endif -#define TclDateclearin TclDatechar = -1 -#define TclDateerrok TclDateerrflag = 0 -extern int TclDatechar; -extern int TclDateerrflag; -YYSTYPE TclDatelval; -YYSTYPE TclDateval; -typedef int TclDatetabelem; -#ifndef YYMAXDEPTH -#define YYMAXDEPTH 150 -#endif -#if YYMAXDEPTH > 0 -int TclDate_TclDates[YYMAXDEPTH], *TclDates = TclDate_TclDates; -YYSTYPE TclDate_TclDatev[YYMAXDEPTH], *TclDatev = TclDate_TclDatev; -#else /* user does initial allocation */ -int *TclDates; -YYSTYPE *TclDatev; -#endif -static int TclDatemaxdepth = YYMAXDEPTH; -# define YYERRCODE 256 - - -/* - * Month and day table. - */ -static TABLE MonthDayTable[] = { - { "january", tMONTH, 1 }, - { "february", tMONTH, 2 }, - { "march", tMONTH, 3 }, - { "april", tMONTH, 4 }, - { "may", tMONTH, 5 }, - { "june", tMONTH, 6 }, - { "july", tMONTH, 7 }, - { "august", tMONTH, 8 }, - { "september", tMONTH, 9 }, - { "sept", tMONTH, 9 }, - { "october", tMONTH, 10 }, - { "november", tMONTH, 11 }, - { "december", tMONTH, 12 }, - { "sunday", tDAY, 0 }, - { "monday", tDAY, 1 }, - { "tuesday", tDAY, 2 }, - { "tues", tDAY, 2 }, - { "wednesday", tDAY, 3 }, - { "wednes", tDAY, 3 }, - { "thursday", tDAY, 4 }, - { "thur", tDAY, 4 }, - { "thurs", tDAY, 4 }, - { "friday", tDAY, 5 }, - { "saturday", tDAY, 6 }, - { NULL } -}; - -/* - * Time units table. - */ -static TABLE UnitsTable[] = { - { "year", tMONTH_UNIT, 12 }, - { "month", tMONTH_UNIT, 1 }, - { "fortnight", tMINUTE_UNIT, 14 * 24 * 60 }, - { "week", tMINUTE_UNIT, 7 * 24 * 60 }, - { "day", tMINUTE_UNIT, 1 * 24 * 60 }, - { "hour", tMINUTE_UNIT, 60 }, - { "minute", tMINUTE_UNIT, 1 }, - { "min", tMINUTE_UNIT, 1 }, - { "second", tSEC_UNIT, 1 }, - { "sec", tSEC_UNIT, 1 }, - { NULL } -}; - -/* - * Assorted relative-time words. - */ -static TABLE OtherTable[] = { - { "tomorrow", tMINUTE_UNIT, 1 * 24 * 60 }, - { "yesterday", tMINUTE_UNIT, -1 * 24 * 60 }, - { "today", tMINUTE_UNIT, 0 }, - { "now", tMINUTE_UNIT, 0 }, - { "last", tUNUMBER, -1 }, - { "this", tMINUTE_UNIT, 0 }, - { "next", tUNUMBER, 2 }, -#if 0 - { "first", tUNUMBER, 1 }, -/* { "second", tUNUMBER, 2 }, */ - { "third", tUNUMBER, 3 }, - { "fourth", tUNUMBER, 4 }, - { "fifth", tUNUMBER, 5 }, - { "sixth", tUNUMBER, 6 }, - { "seventh", tUNUMBER, 7 }, - { "eighth", tUNUMBER, 8 }, - { "ninth", tUNUMBER, 9 }, - { "tenth", tUNUMBER, 10 }, - { "eleventh", tUNUMBER, 11 }, - { "twelfth", tUNUMBER, 12 }, -#endif - { "ago", tAGO, 1 }, - { "epoch", tEPOCH, 0 }, - { NULL } -}; - -/* - * The timezone table. (Note: This table was modified to not use any floating - * point constants to work around an SGI compiler bug). - */ -static TABLE TimezoneTable[] = { - { "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */ - { "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */ - { "utc", tZONE, HOUR( 0) }, - { "wet", tZONE, HOUR( 0) } , /* Western European */ - { "bst", tDAYZONE, HOUR( 0) }, /* British Summer */ - { "wat", tZONE, HOUR( 1) }, /* West Africa */ - { "at", tZONE, HOUR( 2) }, /* Azores */ -#if 0 - /* For completeness. BST is also British Summer, and GST is - * also Guam Standard. */ - { "bst", tZONE, HOUR( 3) }, /* Brazil Standard */ - { "gst", tZONE, HOUR( 3) }, /* Greenland Standard */ -#endif - { "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */ - { "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */ - { "ndt", tDAYZONE, HOUR( 7/2) }, /* Newfoundland Daylight */ - { "ast", tZONE, HOUR( 4) }, /* Atlantic Standard */ - { "adt", tDAYZONE, HOUR( 4) }, /* Atlantic Daylight */ - { "est", tZONE, HOUR( 5) }, /* Eastern Standard */ - { "edt", tDAYZONE, HOUR( 5) }, /* Eastern Daylight */ - { "cst", tZONE, HOUR( 6) }, /* Central Standard */ - { "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */ - { "mst", tZONE, HOUR( 7) }, /* Mountain Standard */ - { "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */ - { "pst", tZONE, HOUR( 8) }, /* Pacific Standard */ - { "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */ - { "yst", tZONE, HOUR( 9) }, /* Yukon Standard */ - { "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */ - { "hst", tZONE, HOUR(10) }, /* Hawaii Standard */ - { "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */ - { "cat", tZONE, HOUR(10) }, /* Central Alaska */ - { "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */ - { "nt", tZONE, HOUR(11) }, /* Nome */ - { "idlw", tZONE, HOUR(12) }, /* International Date Line West */ - { "cet", tZONE, -HOUR( 1) }, /* Central European */ - { "met", tZONE, -HOUR( 1) }, /* Middle European */ - { "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */ - { "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */ - { "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */ - { "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */ - { "fwt", tZONE, -HOUR( 1) }, /* French Winter */ - { "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */ - { "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */ - { "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */ - { "it", tZONE, -HOUR( 7/2) }, /* Iran */ - { "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */ - { "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */ - { "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */ - { "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */ -#if 0 - /* For completeness. NST is also Newfoundland Stanard, nad SST is - * also Swedish Summer. */ - { "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */ - { "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */ -#endif /* 0 */ - { "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */ - { "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */ - { "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */ - { "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */ - { "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */ - { "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */ - { "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */ - { "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */ - { "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */ - { "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */ - { "nzt", tZONE, -HOUR(12) }, /* New Zealand */ - { "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */ - { "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */ - { "idle", tZONE, -HOUR(12) }, /* International Date Line East */ - /* ADDED BY Marco Nijdam */ - { "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */ - /* End ADDED */ - { NULL } -}; - -/* - * Military timezone table. - */ -static TABLE MilitaryTable[] = { - { "a", tZONE, HOUR( 1) }, - { "b", tZONE, HOUR( 2) }, - { "c", tZONE, HOUR( 3) }, - { "d", tZONE, HOUR( 4) }, - { "e", tZONE, HOUR( 5) }, - { "f", tZONE, HOUR( 6) }, - { "g", tZONE, HOUR( 7) }, - { "h", tZONE, HOUR( 8) }, - { "i", tZONE, HOUR( 9) }, - { "k", tZONE, HOUR( 10) }, - { "l", tZONE, HOUR( 11) }, - { "m", tZONE, HOUR( 12) }, - { "n", tZONE, HOUR(- 1) }, - { "o", tZONE, HOUR(- 2) }, - { "p", tZONE, HOUR(- 3) }, - { "q", tZONE, HOUR(- 4) }, - { "r", tZONE, HOUR(- 5) }, - { "s", tZONE, HOUR(- 6) }, - { "t", tZONE, HOUR(- 7) }, - { "u", tZONE, HOUR(- 8) }, - { "v", tZONE, HOUR(- 9) }, - { "w", tZONE, HOUR(-10) }, - { "x", tZONE, HOUR(-11) }, - { "y", tZONE, HOUR(-12) }, - { "z", tZONE, HOUR( 0) }, - { NULL } -}; - - -/* - * Dump error messages in the bit bucket. - */ -static void -TclDateerror(char *s) -{ -} - - -static time_t -ToSeconds(time_t Hours, time_t Minutes, time_t Seconds, MERIDIAN Meridian) -{ - if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) - return -1; - switch (Meridian) { - case MER24: - if (Hours < 0 || Hours > 23) - return -1; - return (Hours * 60L + Minutes) * 60L + Seconds; - case MERam: - if (Hours < 1 || Hours > 12) - return -1; - return ((Hours % 12) * 60L + Minutes) * 60L + Seconds; - case MERpm: - if (Hours < 1 || Hours > 12) - return -1; - return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds; - } - return -1; /* Should never be reached */ -} - - -static int -Convert(time_t Month, time_t Day, time_t Year, - time_t Hours, time_t Minutes, time_t Seconds, - MERIDIAN Meridian, DSTMODE DSTmode, time_t *TimePtr) -{ - static int DaysInMonth[12] = { - 31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 - }; - time_t tod; - time_t Julian; - int i; - - if (Year < 0) - Year = -Year; - if (Year < 100) - Year += 1900; - DaysInMonth[1] = Year % 4 == 0 && (Year % 100 != 0 || Year % 400 == 0) - ? 29 : 28; - if (Month < 1 || Month > 12 - || Year < START_OF_TIME || Year > END_OF_TIME - || Day < 1 || Day > DaysInMonth[(int)--Month]) - return -1; - - for (Julian = Day - 1, i = 0; i < Month; i++) - Julian += DaysInMonth[i]; - if (Year >= EPOCH) { - for (i = EPOCH; i < Year; i++) - Julian += 365 + (i % 4 == 0); - } else { - for (i = Year; i < EPOCH; i++) - Julian -= 365 + (i % 4 == 0); - } - Julian *= SECSPERDAY; - Julian += TclDateTimezone * 60L; - if ((tod = ToSeconds(Hours, Minutes, Seconds, Meridian)) < 0) - return -1; - Julian += tod; - if (DSTmode == DSTon - || (DSTmode == DSTmaybe && localtime(&Julian)->tm_isdst)) - Julian -= 60 * 60; - *TimePtr = Julian; - return 0; -} - - -static time_t -DSTcorrect(time_t Start, time_t Future) -{ - time_t StartDay; - time_t FutureDay; - - StartDay = (localtime(&Start)->tm_hour + 1) % 24; - FutureDay = (localtime(&Future)->tm_hour + 1) % 24; - return (Future - Start) + (StartDay - FutureDay) * 60L * 60L; -} - - -static time_t -RelativeDate(time_t Start, time_t DayOrdinal, time_t DayNumber) -{ - struct tm *tm; - time_t now; - - now = Start; - tm = localtime(&now); - now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7); - now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1); - return DSTcorrect(Start, now); -} - - -static int -RelativeMonth(time_t Start, time_t RelMonth, time_t *TimePtr) -{ - struct tm *tm; - time_t Month; - time_t Year; - time_t Julian; - - if (RelMonth == 0) { - *TimePtr = 0; - return 0; - } - tm = localtime(&Start); - Month = 12 * tm->tm_year + tm->tm_mon + RelMonth; - Year = Month / 12; - Month = Month % 12 + 1; - if (Convert(Month, (time_t)tm->tm_mday, Year, - (time_t)tm->tm_hour, (time_t)tm->tm_min, (time_t)tm->tm_sec, - MER24, DSTmaybe, &Julian) < 0) - return -1; - *TimePtr = DSTcorrect(Start, Julian); - return 0; -} - - -static int -LookupWord(char *buff) -{ - char *p; - char *q; - TABLE *tp; - int i; - int abbrev; - - /* - * Make it lowercase. - */ - for (p = buff; *p; p++) { - if (isupper(*p)) { - *p = (char) tolower(*p); - } - } - - if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) { - TclDatelval.Meridian = MERam; - return tMERIDIAN; - } - if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) { - TclDatelval.Meridian = MERpm; - return tMERIDIAN; - } - - /* - * See if we have an abbreviation for a month. - */ - if (strlen(buff) == 3) { - abbrev = 1; - } else if (strlen(buff) == 4 && buff[3] == '.') { - abbrev = 1; - buff[3] = '\0'; - } else { - abbrev = 0; - } - - for (tp = MonthDayTable; tp->name; tp++) { - if (abbrev) { - if (strncmp(buff, tp->name, 3) == 0) { - TclDatelval.Number = tp->value; - return tp->type; - } - } else if (strcmp(buff, tp->name) == 0) { - TclDatelval.Number = tp->value; - return tp->type; - } - } - - for (tp = TimezoneTable; tp->name; tp++) { - if (strcmp(buff, tp->name) == 0) { - TclDatelval.Number = tp->value; - return tp->type; - } - } - - for (tp = UnitsTable; tp->name; tp++) { - if (strcmp(buff, tp->name) == 0) { - TclDatelval.Number = tp->value; - return tp->type; - } - } - - /* - * Strip off any plural and try the units table again. - */ - i = strlen(buff) - 1; - if (buff[i] == 's') { - buff[i] = '\0'; - for (tp = UnitsTable; tp->name; tp++) { - if (strcmp(buff, tp->name) == 0) { - TclDatelval.Number = tp->value; - return tp->type; - } - } - } - - for (tp = OtherTable; tp->name; tp++) { - if (strcmp(buff, tp->name) == 0) { - TclDatelval.Number = tp->value; - return tp->type; - } - } - - /* - * Military timezones. - */ - if (buff[1] == '\0' && isalpha(*buff)) { - for (tp = MilitaryTable; tp->name; tp++) { - if (strcmp(buff, tp->name) == 0) { - TclDatelval.Number = tp->value; - return tp->type; - } - } - } - - /* - * Drop out any periods and try the timezone table again. - */ - for (i = 0, p = q = buff; *q; q++) - if (*q != '.') - *p++ = *q; - else - i++; - *p = '\0'; - if (i) - for (tp = TimezoneTable; tp->name; tp++) { - if (strcmp(buff, tp->name) == 0) { - TclDatelval.Number = tp->value; - return tp->type; - } - } - - return tID; -} - - -static int -TclDatelex(void) -{ - char c; - char *p; - char buff[20]; - int Count; - int sign; - - for ( ; ; ) { - while (isspace((unsigned char) (*TclDateInput))) { - TclDateInput++; - } - - if (isdigit(c = *TclDateInput) || c == '-' || c == '+') { - if (c == '-' || c == '+') { - sign = c == '-' ? -1 : 1; - if (!isdigit(*++TclDateInput)) { - /* - * skip the '-' sign - */ - continue; - } - } else { - sign = 0; - } - for (TclDatelval.Number = 0; isdigit(c = *TclDateInput++); ) { - TclDatelval.Number = 10 * TclDatelval.Number + c - '0'; - } - TclDateInput--; - if (sign < 0) { - TclDatelval.Number = -TclDatelval.Number; - } - return sign ? tSNUMBER : tUNUMBER; - } - if (isalpha(c)) { - for (p = buff; isalpha(c = *TclDateInput++) || c == '.'; ) { - if (p < &buff[sizeof buff - 1]) { - *p++ = c; - } - } - *p = '\0'; - TclDateInput--; - return LookupWord(buff); - } - if (c != '(') { - return *TclDateInput++; - } - Count = 0; - do { - c = *TclDateInput++; - if (c == '\0') { - return c; - } else if (c == '(') { - Count++; - } else if (c == ')') { - Count--; - } - } while (Count > 0); - } -} - -/* - * Specify zone is of -50000 to force GMT. (This allows BST to work). - */ - -int -TclGetDate(char *p, unsigned long now, long zone, unsigned long *timePtr) -{ - struct tm *tm; - time_t Start; - time_t Time; - time_t tod; - - TclDateInput = p; - tm = localtime((time_t *) &now); - TclDateYear = tm->tm_year; - TclDateMonth = tm->tm_mon + 1; - TclDateDay = tm->tm_mday; - TclDateTimezone = zone; - if (zone == -50000) { - TclDateDSTmode = DSToff; /* assume GMT */ - TclDateTimezone = 0; - } else { - TclDateDSTmode = DSTmaybe; - } - TclDateHour = 0; - TclDateMinutes = 0; - TclDateSeconds = 0; - TclDateMeridian = MER24; - TclDateRelSeconds = 0; - TclDateRelMonth = 0; - TclDateHaveDate = 0; - TclDateHaveDay = 0; - TclDateHaveRel = 0; - TclDateHaveTime = 0; - TclDateHaveZone = 0; - - if (TclDateparse() || TclDateHaveTime > 1 || TclDateHaveZone > 1 || TclDateHaveDate > 1 || - TclDateHaveDay > 1) { - return -1; - } - - if (TclDateHaveDate || TclDateHaveTime || TclDateHaveDay) { - if (Convert(TclDateMonth, TclDateDay, TclDateYear, TclDateHour, TclDateMinutes, TclDateSeconds, - TclDateMeridian, TclDateDSTmode, &Start) < 0) - return -1; - } - else { - Start = now; - if (!TclDateHaveRel) - Start -= ((tm->tm_hour * 60L) + tm->tm_min * 60L) + tm->tm_sec; - } - - Start += TclDateRelSeconds; - if (RelativeMonth(Start, TclDateRelMonth, &Time) < 0) { - return -1; - } - Start += Time; - - if (TclDateHaveDay && !TclDateHaveDate) { - tod = RelativeDate(Start, TclDateDayOrdinal, TclDateDayNumber); - Start += tod; - } - - *timePtr = Start; - return 0; -} -TclDatetabelem TclDateexca[] ={ --1, 1, - 0, -1, - -2, 0, - }; -# define YYNPROD 41 -# define YYLAST 227 -TclDatetabelem TclDateact[]={ - - 14, 11, 23, 28, 17, 12, 19, 18, 16, 9, - 10, 13, 42, 21, 46, 45, 44, 48, 41, 37, - 36, 35, 32, 29, 34, 33, 31, 43, 39, 38, - 30, 15, 8, 7, 6, 5, 4, 3, 2, 1, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 47, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 22, 0, 0, 20, 25, 24, 27, - 26, 42, 0, 0, 0, 0, 40 }; -TclDatetabelem TclDatepact[]={ - --10000000, -258,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000, -45, - -267,-10000000, -244,-10000000, -14, -231, -240,-10000000,-10000000,-10000000, --10000000, -246,-10000000, -247, -248,-10000000,-10000000,-10000000,-10000000, -15, --10000000,-10000000,-10000000,-10000000,-10000000, -40, -20,-10000000, -251,-10000000, --10000000, -252,-10000000, -253,-10000000, -249,-10000000,-10000000,-10000000 }; -TclDatetabelem TclDatepgo[]={ - - 0, 28, 39, 38, 37, 36, 35, 34, 33, 32, - 31 }; -TclDatetabelem TclDater1[]={ - - 0, 2, 2, 3, 3, 3, 3, 3, 3, 4, - 4, 4, 4, 4, 5, 5, 5, 7, 7, 7, - 6, 6, 6, 6, 6, 6, 6, 8, 8, 10, - 10, 10, 10, 10, 10, 10, 10, 10, 9, 1, - 1 }; -TclDatetabelem TclDater2[]={ - - 0, 0, 4, 3, 3, 3, 3, 3, 2, 5, - 9, 9, 13, 13, 5, 3, 3, 3, 5, 5, - 7, 11, 5, 9, 5, 3, 7, 5, 2, 5, - 5, 3, 5, 5, 3, 5, 5, 3, 3, 1, - 3 }; -TclDatetabelem TclDatechk[]={ - --10000000, -2, -3, -4, -5, -6, -7, -8, -9, 267, - 268, 259, 263, 269, 258, -10, 266, 262, 265, 264, - 261, 58, 258, 47, 263, 262, 265, 264, 270, 267, - 44, 257, 262, 265, 264, 267, 267, 267, 44, -1, - 266, 58, 261, 47, 267, 267, 267, -1, 266 }; -TclDatetabelem TclDatedef[]={ - - 1, -2, 2, 3, 4, 5, 6, 7, 8, 38, - 15, 16, 0, 25, 17, 28, 0, 31, 34, 37, - 9, 0, 19, 0, 24, 29, 33, 36, 14, 22, - 18, 27, 30, 32, 35, 39, 20, 26, 0, 10, - 11, 0, 40, 0, 23, 39, 21, 12, 13 }; -typedef struct -#ifdef __cplusplus - TclDatetoktype -#endif -{ char *t_name; int t_val; } TclDatetoktype; -#ifndef YYDEBUG -# define YYDEBUG 0 /* don't allow debugging */ -#endif - -#if YYDEBUG - -TclDatetoktype TclDatetoks[] = -{ - "tAGO", 257, - "tDAY", 258, - "tDAYZONE", 259, - "tID", 260, - "tMERIDIAN", 261, - "tMINUTE_UNIT", 262, - "tMONTH", 263, - "tMONTH_UNIT", 264, - "tSEC_UNIT", 265, - "tSNUMBER", 266, - "tUNUMBER", 267, - "tZONE", 268, - "tEPOCH", 269, - "tDST", 270, - "-unknown-", -1 /* ends search */ -}; - -char * TclDatereds[] = -{ - "-no such reduction-", - "spec : /* empty */", - "spec : spec item", - "item : time", - "item : zone", - "item : date", - "item : day", - "item : rel", - "item : number", - "time : tUNUMBER tMERIDIAN", - "time : tUNUMBER ':' tUNUMBER o_merid", - "time : tUNUMBER ':' tUNUMBER tSNUMBER", - "time : tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid", - "time : tUNUMBER ':' tUNUMBER ':' tUNUMBER tSNUMBER", - "zone : tZONE tDST", - "zone : tZONE", - "zone : tDAYZONE", - "day : tDAY", - "day : tDAY ','", - "day : tUNUMBER tDAY", - "date : tUNUMBER '/' tUNUMBER", - "date : tUNUMBER '/' tUNUMBER '/' tUNUMBER", - "date : tMONTH tUNUMBER", - "date : tMONTH tUNUMBER ',' tUNUMBER", - "date : tUNUMBER tMONTH", - "date : tEPOCH", - "date : tUNUMBER tMONTH tUNUMBER", - "rel : relunit tAGO", - "rel : relunit", - "relunit : tUNUMBER tMINUTE_UNIT", - "relunit : tSNUMBER tMINUTE_UNIT", - "relunit : tMINUTE_UNIT", - "relunit : tSNUMBER tSEC_UNIT", - "relunit : tUNUMBER tSEC_UNIT", - "relunit : tSEC_UNIT", - "relunit : tSNUMBER tMONTH_UNIT", - "relunit : tUNUMBER tMONTH_UNIT", - "relunit : tMONTH_UNIT", - "number : tUNUMBER", - "o_merid : /* empty */", - "o_merid : tMERIDIAN", -}; -#endif /* YYDEBUG */ -/* - * Copyright (c) 1993 by Sun Microsystems, Inc. - */ - - -/* -** Skeleton parser driver for yacc output -*/ - -/* -** yacc user known macros and defines -*/ -#define YYERROR goto TclDateerrlab -#define YYACCEPT return(0) -#define YYABORT return(1) -#define YYBACKUP( newtoken, newvalue )\ -{\ - if ( TclDatechar >= 0 || ( TclDater2[ TclDatetmp ] >> 1 ) != 1 )\ - {\ - TclDateerror( "syntax error - cannot backup" );\ - goto TclDateerrlab;\ - }\ - TclDatechar = newtoken;\ - TclDatestate = *TclDateps;\ - TclDatelval = newvalue;\ - goto TclDatenewstate;\ -} -#define YYRECOVERING() (!!TclDateerrflag) -#define YYNEW(type) malloc(sizeof(type) * TclDatenewmax) -#define YYCOPY(to, from, type) \ - (type *) memcpy(to, (char *) from, TclDatenewmax * sizeof(type)) -#define YYENLARGE( from, type) \ - (type *) realloc((char *) from, TclDatenewmax * sizeof(type)) -#ifndef YYDEBUG -# define YYDEBUG 1 /* make debugging available */ -#endif - -/* -** user known globals -*/ -int TclDatedebug; /* set to 1 to get debugging */ - -/* -** driver internal defines -*/ -#define YYFLAG (-10000000) - -/* -** global variables used by the parser -*/ -YYSTYPE *TclDatepv; /* top of value stack */ -int *TclDateps; /* top of state stack */ - -int TclDatestate; /* current state */ -int TclDatetmp; /* extra var (lasts between blocks) */ - -int TclDatenerrs; /* number of errors */ -int TclDateerrflag; /* error recovery flag */ -int TclDatechar; /* current input token number */ - - - -#ifdef YYNMBCHARS -#define YYLEX() TclDatecvtok(TclDatelex()) -/* -** TclDatecvtok - return a token if i is a wchar_t value that exceeds 255. -** If i<255, i itself is the token. If i>255 but the neither -** of the 30th or 31st bit is on, i is already a token. -*/ -#if defined(__STDC__) || defined(__cplusplus) -int TclDatecvtok(int i) -#else -int TclDatecvtok(i) int i; -#endif -{ - int first = 0; - int last = YYNMBCHARS - 1; - int mid; - wchar_t j; - - if(i&0x60000000){/*Must convert to a token. */ - if( TclDatembchars[last].character < i ){ - return i;/*Giving up*/ - } - while ((last>=first)&&(first>=0)) {/*Binary search loop*/ - mid = (first+last)/2; - j = TclDatembchars[mid].character; - if( j==i ){/*Found*/ - return TclDatembchars[mid].tvalue; - }else if( j= 0; - TclDate_i++ ) - { - if ( TclDatetoks[TclDate_i].t_val == TclDatechar ) - break; - } - printf( "%s\n", TclDatetoks[TclDate_i].t_name ); - } - } -#endif /* YYDEBUG */ - if ( ++TclDate_ps >= &TclDates[ TclDatemaxdepth ] ) /* room on stack? */ - { - /* - ** reallocate and recover. Note that pointers - ** have to be reset, or bad things will happen - */ - int TclDateps_index = (TclDate_ps - TclDates); - int TclDatepv_index = (TclDate_pv - TclDatev); - int TclDatepvt_index = (TclDatepvt - TclDatev); - int TclDatenewmax; -#ifdef YYEXPAND - TclDatenewmax = YYEXPAND(TclDatemaxdepth); -#else - TclDatenewmax = 2 * TclDatemaxdepth; /* double table size */ - if (TclDatemaxdepth == YYMAXDEPTH) /* first time growth */ - { - char *newTclDates = (char *)YYNEW(int); - char *newTclDatev = (char *)YYNEW(YYSTYPE); - if (newTclDates != 0 && newTclDatev != 0) - { - TclDates = YYCOPY(newTclDates, TclDates, int); - TclDatev = YYCOPY(newTclDatev, TclDatev, YYSTYPE); - } - else - TclDatenewmax = 0; /* failed */ - } - else /* not first time */ - { - TclDates = YYENLARGE(TclDates, int); - TclDatev = YYENLARGE(TclDatev, YYSTYPE); - if (TclDates == 0 || TclDatev == 0) - TclDatenewmax = 0; /* failed */ - } -#endif - if (TclDatenewmax <= TclDatemaxdepth) /* tables not expanded */ - { - TclDateerror( "yacc stack overflow" ); - YYABORT; - } - TclDatemaxdepth = TclDatenewmax; - - TclDate_ps = TclDates + TclDateps_index; - TclDate_pv = TclDatev + TclDatepv_index; - TclDatepvt = TclDatev + TclDatepvt_index; - } - *TclDate_ps = TclDate_state; - *++TclDate_pv = TclDateval; - - /* - ** we have a new state - find out what to do - */ - TclDate_newstate: - if ( ( TclDate_n = TclDatepact[ TclDate_state ] ) <= YYFLAG ) - goto TclDatedefault; /* simple state */ -#if YYDEBUG - /* - ** if debugging, need to mark whether new token grabbed - */ - TclDatetmp = TclDatechar < 0; -#endif - if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) ) - TclDatechar = 0; /* reached EOF */ -#if YYDEBUG - if ( TclDatedebug && TclDatetmp ) - { - int TclDate_i; - - printf( "Received token " ); - if ( TclDatechar == 0 ) - printf( "end-of-file\n" ); - else if ( TclDatechar < 0 ) - printf( "-none-\n" ); - else - { - for ( TclDate_i = 0; TclDatetoks[TclDate_i].t_val >= 0; - TclDate_i++ ) - { - if ( TclDatetoks[TclDate_i].t_val == TclDatechar ) - break; - } - printf( "%s\n", TclDatetoks[TclDate_i].t_name ); - } - } -#endif /* YYDEBUG */ - if ( ( ( TclDate_n += TclDatechar ) < 0 ) || ( TclDate_n >= YYLAST ) ) - goto TclDatedefault; - if ( TclDatechk[ TclDate_n = TclDateact[ TclDate_n ] ] == TclDatechar ) /*valid shift*/ - { - TclDatechar = -1; - TclDateval = TclDatelval; - TclDate_state = TclDate_n; - if ( TclDateerrflag > 0 ) - TclDateerrflag--; - goto TclDate_stack; - } - - TclDatedefault: - if ( ( TclDate_n = TclDatedef[ TclDate_state ] ) == -2 ) - { -#if YYDEBUG - TclDatetmp = TclDatechar < 0; -#endif - if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) ) - TclDatechar = 0; /* reached EOF */ -#if YYDEBUG - if ( TclDatedebug && TclDatetmp ) - { - int TclDate_i; - - printf( "Received token " ); - if ( TclDatechar == 0 ) - printf( "end-of-file\n" ); - else if ( TclDatechar < 0 ) - printf( "-none-\n" ); - else - { - for ( TclDate_i = 0; - TclDatetoks[TclDate_i].t_val >= 0; - TclDate_i++ ) - { - if ( TclDatetoks[TclDate_i].t_val - == TclDatechar ) - { - break; - } - } - printf( "%s\n", TclDatetoks[TclDate_i].t_name ); - } - } -#endif /* YYDEBUG */ - /* - ** look through exception table - */ - { - int *TclDatexi = TclDateexca; - - while ( ( *TclDatexi != -1 ) || - ( TclDatexi[1] != TclDate_state ) ) - { - TclDatexi += 2; - } - while ( ( *(TclDatexi += 2) >= 0 ) && - ( *TclDatexi != TclDatechar ) ) - ; - if ( ( TclDate_n = TclDatexi[1] ) < 0 ) - YYACCEPT; - } - } - - /* - ** check for syntax error - */ - if ( TclDate_n == 0 ) /* have an error */ - { - /* no worry about speed here! */ - switch ( TclDateerrflag ) - { - case 0: /* new error */ - TclDateerror( "syntax error" ); - goto skip_init; - /* - ** get globals into registers. - ** we have a user generated syntax type error - */ - TclDate_pv = TclDatepv; - TclDate_ps = TclDateps; - TclDate_state = TclDatestate; - skip_init: - TclDatenerrs++; - /* FALLTHRU */ - case 1: - case 2: /* incompletely recovered error */ - /* try again... */ - TclDateerrflag = 3; - /* - ** find state where "error" is a legal - ** shift action - */ - while ( TclDate_ps >= TclDates ) - { - TclDate_n = TclDatepact[ *TclDate_ps ] + YYERRCODE; - if ( TclDate_n >= 0 && TclDate_n < YYLAST && - TclDatechk[TclDateact[TclDate_n]] == YYERRCODE) { - /* - ** simulate shift of "error" - */ - TclDate_state = TclDateact[ TclDate_n ]; - goto TclDate_stack; - } - /* - ** current state has no shift on - ** "error", pop stack - */ -#if YYDEBUG -# define _POP_ "Error recovery pops state %d, uncovers state %d\n" - if ( TclDatedebug ) - printf( _POP_, *TclDate_ps, - TclDate_ps[-1] ); -# undef _POP_ -#endif - TclDate_ps--; - TclDate_pv--; - } - /* - ** there is no state on stack with "error" as - ** a valid shift. give up. - */ - YYABORT; - case 3: /* no shift yet; eat a token */ -#if YYDEBUG - /* - ** if debugging, look up token in list of - ** pairs. 0 and negative shouldn't occur, - ** but since timing doesn't matter when - ** debugging, it doesn't hurt to leave the - ** tests here. - */ - if ( TclDatedebug ) - { - int TclDate_i; - - printf( "Error recovery discards " ); - if ( TclDatechar == 0 ) - printf( "token end-of-file\n" ); - else if ( TclDatechar < 0 ) - printf( "token -none-\n" ); - else - { - for ( TclDate_i = 0; - TclDatetoks[TclDate_i].t_val >= 0; - TclDate_i++ ) - { - if ( TclDatetoks[TclDate_i].t_val - == TclDatechar ) - { - break; - } - } - printf( "token %s\n", - TclDatetoks[TclDate_i].t_name ); - } - } -#endif /* YYDEBUG */ - if ( TclDatechar == 0 ) /* reached EOF. quit */ - YYABORT; - TclDatechar = -1; - goto TclDate_newstate; - } - }/* end if ( TclDate_n == 0 ) */ - /* - ** reduction by production TclDate_n - ** put stack tops, etc. so things right after switch - */ -#if YYDEBUG - /* - ** if debugging, print the string that is the user's - ** specification of the reduction which is just about - ** to be done. - */ - if ( TclDatedebug ) - printf( "Reduce by (%d) \"%s\"\n", - TclDate_n, TclDatereds[ TclDate_n ] ); -#endif - TclDatetmp = TclDate_n; /* value to switch over */ - TclDatepvt = TclDate_pv; /* $vars top of value stack */ - /* - ** Look in goto table for next state - ** Sorry about using TclDate_state here as temporary - ** register variable, but why not, if it works... - ** If TclDater2[ TclDate_n ] doesn't have the low order bit - ** set, then there is no action to be done for - ** this reduction. So, no saving & unsaving of - ** registers done. The only difference between the - ** code just after the if and the body of the if is - ** the goto TclDate_stack in the body. This way the test - ** can be made before the choice of what to do is needed. - */ - { - /* length of production doubled with extra bit */ - int TclDate_len = TclDater2[ TclDate_n ]; - - if ( !( TclDate_len & 01 ) ) - { - TclDate_len >>= 1; - TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */ - TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] + - *( TclDate_ps -= TclDate_len ) + 1; - if ( TclDate_state >= YYLAST || - TclDatechk[ TclDate_state = - TclDateact[ TclDate_state ] ] != -TclDate_n ) - { - TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ]; - } - goto TclDate_stack; - } - TclDate_len >>= 1; - TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */ - TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] + - *( TclDate_ps -= TclDate_len ) + 1; - if ( TclDate_state >= YYLAST || - TclDatechk[ TclDate_state = TclDateact[ TclDate_state ] ] != -TclDate_n ) - { - TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ]; - } - } - /* save until reenter driver code */ - TclDatestate = TclDate_state; - TclDateps = TclDate_ps; - TclDatepv = TclDate_pv; - } - /* - ** code supplied by user is placed in this switch - */ - switch( TclDatetmp ) - { - -case 3:{ - TclDateHaveTime++; - } break; -case 4:{ - TclDateHaveZone++; - } break; -case 5:{ - TclDateHaveDate++; - } break; -case 6:{ - TclDateHaveDay++; - } break; -case 7:{ - TclDateHaveRel++; - } break; -case 9:{ - TclDateHour = TclDatepvt[-1].Number; - TclDateMinutes = 0; - TclDateSeconds = 0; - TclDateMeridian = TclDatepvt[-0].Meridian; - } break; -case 10:{ - TclDateHour = TclDatepvt[-3].Number; - TclDateMinutes = TclDatepvt[-1].Number; - TclDateSeconds = 0; - TclDateMeridian = TclDatepvt[-0].Meridian; - } break; -case 11:{ - TclDateHour = TclDatepvt[-3].Number; - TclDateMinutes = TclDatepvt[-1].Number; - TclDateMeridian = MER24; - TclDateDSTmode = DSToff; - TclDateTimezone = - (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60); - } break; -case 12:{ - TclDateHour = TclDatepvt[-5].Number; - TclDateMinutes = TclDatepvt[-3].Number; - TclDateSeconds = TclDatepvt[-1].Number; - TclDateMeridian = TclDatepvt[-0].Meridian; - } break; -case 13:{ - TclDateHour = TclDatepvt[-5].Number; - TclDateMinutes = TclDatepvt[-3].Number; - TclDateSeconds = TclDatepvt[-1].Number; - TclDateMeridian = MER24; - TclDateDSTmode = DSToff; - TclDateTimezone = - (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60); - } break; -case 14:{ - TclDateTimezone = TclDatepvt[-1].Number; - TclDateDSTmode = DSTon; - } break; -case 15:{ - TclDateTimezone = TclDatepvt[-0].Number; - TclDateDSTmode = DSToff; - } break; -case 16:{ - TclDateTimezone = TclDatepvt[-0].Number; - TclDateDSTmode = DSTon; - } break; -case 17:{ - TclDateDayOrdinal = 1; - TclDateDayNumber = TclDatepvt[-0].Number; - } break; -case 18:{ - TclDateDayOrdinal = 1; - TclDateDayNumber = TclDatepvt[-1].Number; - } break; -case 19:{ - TclDateDayOrdinal = TclDatepvt[-1].Number; - TclDateDayNumber = TclDatepvt[-0].Number; - } break; -case 20:{ - TclDateMonth = TclDatepvt[-2].Number; - TclDateDay = TclDatepvt[-0].Number; - } break; -case 21:{ - TclDateMonth = TclDatepvt[-4].Number; - TclDateDay = TclDatepvt[-2].Number; - TclDateYear = TclDatepvt[-0].Number; - } break; -case 22:{ - TclDateMonth = TclDatepvt[-1].Number; - TclDateDay = TclDatepvt[-0].Number; - } break; -case 23:{ - TclDateMonth = TclDatepvt[-3].Number; - TclDateDay = TclDatepvt[-2].Number; - TclDateYear = TclDatepvt[-0].Number; - } break; -case 24:{ - TclDateMonth = TclDatepvt[-0].Number; - TclDateDay = TclDatepvt[-1].Number; - } break; -case 25:{ - TclDateMonth = 1; - TclDateDay = 1; - TclDateYear = EPOCH; - } break; -case 26:{ - TclDateMonth = TclDatepvt[-1].Number; - TclDateDay = TclDatepvt[-2].Number; - TclDateYear = TclDatepvt[-0].Number; - } break; -case 27:{ - TclDateRelSeconds = -TclDateRelSeconds; - TclDateRelMonth = -TclDateRelMonth; - } break; -case 29:{ - TclDateRelSeconds += TclDatepvt[-1].Number * TclDatepvt[-0].Number * 60L; - } break; -case 30:{ - TclDateRelSeconds += TclDatepvt[-1].Number * TclDatepvt[-0].Number * 60L; - } break; -case 31:{ - TclDateRelSeconds += TclDatepvt[-0].Number * 60L; - } break; -case 32:{ - TclDateRelSeconds += TclDatepvt[-1].Number; - } break; -case 33:{ - TclDateRelSeconds += TclDatepvt[-1].Number; - } break; -case 34:{ - TclDateRelSeconds++; - } break; -case 35:{ - TclDateRelMonth += TclDatepvt[-1].Number * TclDatepvt[-0].Number; - } break; -case 36:{ - TclDateRelMonth += TclDatepvt[-1].Number * TclDatepvt[-0].Number; - } break; -case 37:{ - TclDateRelMonth += TclDatepvt[-0].Number; - } break; -case 38:{ - if (TclDateHaveTime && TclDateHaveDate && !TclDateHaveRel) - TclDateYear = TclDatepvt[-0].Number; - else { - TclDateHaveTime++; - if (TclDatepvt[-0].Number < 100) { - TclDateHour = TclDatepvt[-0].Number; - TclDateMinutes = 0; - } - else { - TclDateHour = TclDatepvt[-0].Number / 100; - TclDateMinutes = TclDatepvt[-0].Number % 100; - } - TclDateSeconds = 0; - TclDateMeridian = MER24; - } - } break; -case 39:{ - TclDateval.Meridian = MER24; - } break; -case 40:{ - TclDateval.Meridian = TclDatepvt[-0].Meridian; - } break; - } - goto TclDatestack; /* reset registers in driver code */ -} - diff --git a/cde/programs/dtdocbook/tcl/tclEnv.c b/cde/programs/dtdocbook/tcl/tclEnv.c deleted file mode 100644 index d45992d3..00000000 --- a/cde/programs/dtdocbook/tcl/tclEnv.c +++ /dev/null @@ -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); -} diff --git a/cde/programs/dtdocbook/tcl/tclEvent.c b/cde/programs/dtdocbook/tcl/tclEvent.c deleted file mode 100644 index 2f2bdaea..00000000 --- a/cde/programs/dtdocbook/tcl/tclEvent.c +++ /dev/null @@ -1,2241 +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: tclEvent.c /main/2 1996/08/08 14:43:41 cde-hp $ */ -/* - * tclEvent.c -- - * - * This file provides basic event-managing facilities for Tcl, - * including an event queue, and mechanisms for attaching - * callbacks to certain events. - * - * It also contains the command procedures for the commands - * "after", "vwait", and "update". - * - * Copyright (c) 1990-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: @(#) tclEvent.c 1.127 96/03/22 12:12:33 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * For each file registered in a call to Tcl_CreateFileHandler, - * there is one record of the following type. All of these records - * are chained together into a single list. - */ - -typedef struct FileHandler { - Tcl_File file; /* Generic file handle for file. */ - int mask; /* Mask of desired events: TCL_READABLE, etc. */ - int readyMask; /* Events that were ready the last time that - * FileHandlerCheckProc checked this file. */ - Tcl_FileProc *proc; /* Procedure to call, in the style of - * Tcl_CreateFileHandler. This is NULL - * if the handler was created by - * Tcl_CreateFileHandler2. */ - ClientData clientData; /* Argument to pass to proc. */ - struct FileHandler *nextPtr;/* Next in list of all files we care - * about (NULL for end of list). */ -} FileHandler; - -static FileHandler *firstFileHandlerPtr = (FileHandler *) NULL; - /* List of all file handlers. */ -static int fileEventSourceCreated = 0; - /* Non-zero means that the file event source - * hasn't been registerd with the Tcl - * notifier yet. */ - -/* - * The following structure is what is added to the Tcl event queue when - * file handlers are ready to fire. - */ - -typedef struct FileHandlerEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - Tcl_File file; /* File descriptor that is ready. Used - * to find the FileHandler structure for - * the file (can't point directly to the - * FileHandler structure because it could - * go away while the event is queued). */ -} FileHandlerEvent; - -/* - * For each timer callback that's pending (either regular or "modal"), - * there is one record of the following type. The normal handlers - * (created by Tcl_CreateTimerHandler) are chained together in a - * list sorted by time (earliest event first). - */ - -typedef struct TimerHandler { - Tcl_Time time; /* When timer is to fire. */ - Tcl_TimerProc *proc; /* Procedure to call. */ - ClientData clientData; /* Argument to pass to proc. */ - Tcl_TimerToken token; /* Identifies event so it can be - * deleted. Not used in modal - * timeouts. */ - struct TimerHandler *nextPtr; /* Next event in queue, or NULL for - * end of queue. */ -} TimerHandler; - -static TimerHandler *firstTimerHandlerPtr = NULL; - /* First event in queue. */ -static int timerEventSourceCreated = 0; /* 0 means that the timer event source - * hasn't yet been registered with the - * Tcl notifier. */ - -/* - * The information below describes a stack of modal timeouts managed by - * Tcl_CreateModalTimer and Tcl_DeleteModalTimer. Only the first element - * in the list is used at any given time. - */ - -static TimerHandler *firstModalHandlerPtr = NULL; - -/* - * The following structure is what's added to the Tcl event queue when - * timer handlers are ready to fire. - */ - -typedef struct TimerEvent { - Tcl_Event header; /* Information that is standard for - * all events. */ - Tcl_Time time; /* All timer events that specify this - * time or earlier are ready - * to fire. */ -} TimerEvent; - -/* - * There is one of the following structures for each of the - * handlers declared in a call to Tcl_DoWhenIdle. All of the - * currently-active handlers are linked together into a list. - */ - -typedef struct IdleHandler { - Tcl_IdleProc (*proc); /* Procedure to call. */ - ClientData clientData; /* Value to pass to proc. */ - int generation; /* Used to distinguish older handlers from - * recently-created ones. */ - struct IdleHandler *nextPtr;/* Next in list of active handlers. */ -} IdleHandler; - -static IdleHandler *idleList = NULL; - /* First in list of all idle handlers. */ -static IdleHandler *lastIdlePtr = NULL; - /* Last in list (or NULL for empty list). */ -static int idleGeneration = 0; /* Used to fill in the "generation" fields - * of IdleHandler structures. Increments - * each time Tcl_DoOneEvent starts calling - * idle handlers, so that all old handlers - * can be called without calling any of the - * new ones created by old ones. */ - -/* - * The data structure below is used by the "after" command to remember - * the command to be executed later. All of the pending "after" commands - * for an interpreter are linked together in a list. - */ - -typedef struct AfterInfo { - struct AfterAssocData *assocPtr; - /* Pointer to the "tclAfter" assocData for - * the interp in which command will be - * executed. */ - char *command; /* Command to execute. Malloc'ed, so must - * be freed when structure is deallocated. */ - int id; /* Integer identifier for command; used to - * cancel it. */ - Tcl_TimerToken token; /* Used to cancel the "after" command. NULL - * means that the command is run as an - * idle handler rather than as a timer - * handler. NULL means this is an "after - * idle" handler rather than a - * timer handler. */ - struct AfterInfo *nextPtr; /* Next in list of all "after" commands for - * this interpreter. */ -} AfterInfo; - -/* - * One of the following structures is associated with each interpreter - * for which an "after" command has ever been invoked. A pointer to - * this structure is stored in the AssocData for the "tclAfter" key. - */ - -typedef struct AfterAssocData { - Tcl_Interp *interp; /* The interpreter for which this data is - * registered. */ - AfterInfo *firstAfterPtr; /* First in list of all "after" commands - * still pending for this interpreter, or - * NULL if none. */ -} AfterAssocData; - -/* - * The data structure below is used to report background errors. One - * such structure is allocated for each error; it holds information - * about the interpreter and the error until bgerror can be invoked - * later as an idle handler. - */ - -typedef struct BgError { - Tcl_Interp *interp; /* Interpreter in which error occurred. NULL - * means this error report has been cancelled - * (a previous report generated a break). */ - char *errorMsg; /* The error message (interp->result when - * the error occurred). Malloc-ed. */ - char *errorInfo; /* Value of the errorInfo variable - * (malloc-ed). */ - char *errorCode; /* Value of the errorCode variable - * (malloc-ed). */ - struct BgError *nextPtr; /* Next in list of all pending error - * reports for this interpreter, or NULL - * for end of list. */ -} BgError; - -/* - * One of the structures below is associated with the "tclBgError" - * assoc data for each interpreter. It keeps track of the head and - * tail of the list of pending background errors for the interpreter. - */ - -typedef struct ErrAssocData { - BgError *firstBgPtr; /* First in list of all background errors - * waiting to be processed for this - * interpreter (NULL if none). */ - BgError *lastBgPtr; /* Last in list of all background errors - * waiting to be processed for this - * interpreter (NULL if none). */ -} ErrAssocData; - -/* - * For each exit handler created with a call to Tcl_CreateExitHandler - * there is a structure of the following type: - */ - -typedef struct ExitHandler { - Tcl_ExitProc *proc; /* Procedure to call when process exits. */ - ClientData clientData; /* One word of information to pass to proc. */ - struct ExitHandler *nextPtr;/* Next in list of all exit handlers for - * this application, or NULL for end of list. */ -} ExitHandler; - -static ExitHandler *firstExitPtr = NULL; - /* First in list of all exit handlers for - * application. */ - -/* - * Structures of the following type are used during the execution - * of Tcl_WaitForFile, to keep track of the file and timeout. - */ - -typedef struct FileWait { - Tcl_File file; /* File to wait on. */ - int mask; /* Conditions to wait for (TCL_READABLE, - * etc.) */ - int timeout; /* Original "timeout" argument to - * Tcl_WaitForFile. */ - Tcl_Time abortTime; /* Time at which to abort the wait. */ - int present; /* Conditions present on the file during - * the last time through the event loop. */ - int done; /* Non-zero means we're done: either one of - * the desired conditions is present or the - * timeout period has elapsed. */ -} FileWait; - -/* - * The following variable is a "secret" indication to Tcl_Exit that - * it should dump out the state of memory before exiting. If the - * value is non-NULL, it gives the name of the file in which to - * dump memory usage information. - */ - -char *tclMemDumpFileName = NULL; - -/* - * Prototypes for procedures referenced only in this file: - */ - -static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp)); -static void AfterProc _ANSI_ARGS_((ClientData clientData)); -static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp)); -static void FileHandlerCheckProc _ANSI_ARGS_(( - ClientData clientData, int flags)); -static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, - int flags)); -static void FileHandlerExitProc _ANSI_ARGS_((ClientData data)); -static void FileHandlerSetupProc _ANSI_ARGS_(( - ClientData clientData, int flags)); -static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr)); -static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr, - char *string)); -static void HandleBgErrors _ANSI_ARGS_((ClientData clientData)); -static void TimerHandlerCheckProc _ANSI_ARGS_(( - ClientData clientData, int flags)); -static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, - int flags)); -static void TimerHandlerExitProc _ANSI_ARGS_((ClientData data)); -static void TimerHandlerSetupProc _ANSI_ARGS_(( - ClientData clientData, int flags)); -static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *name1, char *name2, - int flags)); - -/* - *-------------------------------------------------------------- - * - * Tcl_CreateFileHandler -- - * - * Arrange for a given procedure to be invoked whenever - * a given file becomes readable or writable. - * - * Results: - * None. - * - * Side effects: - * From now on, whenever the I/O channel given by file becomes - * ready in the way indicated by mask, proc will be invoked. - * See the manual entry for details on the calling sequence - * to proc. If file is already registered then the old mask - * and proc and clientData values will be replaced with - * new ones. - * - *-------------------------------------------------------------- - */ - -void -Tcl_CreateFileHandler( - Tcl_File file, /* Handle of stream to watch. */ - int mask, /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: - * indicates conditions under which - * proc should be called. */ - Tcl_FileProc *proc, /* Procedure to call for each - * selected event. */ - ClientData clientData /* Arbitrary data to pass to proc. */ -) -{ - FileHandler *filePtr; - - if (!fileEventSourceCreated) { - fileEventSourceCreated = 1; - Tcl_CreateEventSource(FileHandlerSetupProc, FileHandlerCheckProc, - (ClientData) NULL); - Tcl_CreateExitHandler(FileHandlerExitProc, (ClientData) NULL); - } - - /* - * Make sure the file isn't already registered. Create a - * new record in the normal case where there's no existing - * record. - */ - - for (filePtr = firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->file == file) { - break; - } - } - if (filePtr == NULL) { - filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); - filePtr->file = file; - filePtr->nextPtr = firstFileHandlerPtr; - firstFileHandlerPtr = filePtr; - } - - /* - * The remainder of the initialization below is done regardless - * of whether or not this is a new record or a modification of - * an old one. - */ - - filePtr->mask = mask; - filePtr->readyMask = 0; - filePtr->proc = proc; - filePtr->clientData = clientData; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_DeleteFileHandler -- - * - * Cancel a previously-arranged callback arrangement for - * a file. - * - * Results: - * None. - * - * Side effects: - * If a callback was previously registered on file, remove it. - * - *-------------------------------------------------------------- - */ - -void -Tcl_DeleteFileHandler( - Tcl_File file /* Stream id for which to remove - * callback procedure. */ -) -{ - FileHandler *filePtr, *prevPtr; - - /* - * Find the entry for the given file (and return if there - * isn't one). - */ - - for (prevPtr = NULL, filePtr = firstFileHandlerPtr; ; - prevPtr = filePtr, filePtr = filePtr->nextPtr) { - if (filePtr == NULL) { - return; - } - if (filePtr->file == file) { - break; - } - } - - /* - * Clean up information in the callback record. - */ - - if (prevPtr == NULL) { - firstFileHandlerPtr = filePtr->nextPtr; - } else { - prevPtr->nextPtr = filePtr->nextPtr; - } - ckfree((char *) filePtr); -} - -/* - *---------------------------------------------------------------------- - * - * FileHandlerExitProc -- - * - * Cleanup procedure to delete the file event source during exit - * cleanup. - * - * Results: - * None. - * - * Side effects: - * Destroys the file event source. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -FileHandlerExitProc( - ClientData clientData /* Not used. */ -) -{ - Tcl_DeleteEventSource(FileHandlerSetupProc, FileHandlerCheckProc, - (ClientData) NULL); -} - -/* - *---------------------------------------------------------------------- - * - * FileHandlerSetupProc -- - * - * This procedure is part of the "event source" for file handlers. - * It is invoked by Tcl_DoOneEvent before it calls select (or - * whatever it uses to wait). - * - * Results: - * None. - * - * Side effects: - * Tells the notifier which files should be waited for. - * - *---------------------------------------------------------------------- - */ - -static void -FileHandlerSetupProc( - ClientData clientData, /* Not used. */ - int flags /* Flags passed to Tk_DoOneEvent: - * if it doesn't include - * TCL_FILE_EVENTS then we do - * nothing. */ -) -{ - FileHandler *filePtr; - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - for (filePtr = firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->mask != 0) { - Tcl_WatchFile(filePtr->file, filePtr->mask); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * FileHandlerCheckProc -- - * - * This procedure is the second part of the "event source" for - * file handlers. It is invoked by Tcl_DoOneEvent after it calls - * select (or whatever it uses to wait for events). - * - * Results: - * None. - * - * Side effects: - * Makes entries on the Tcl event queue for each file that is - * now ready. - * - *---------------------------------------------------------------------- - */ - -static void -FileHandlerCheckProc( - ClientData clientData, /* Not used. */ - int flags /* Flags passed to Tk_DoOneEvent: - * if it doesn't include - * TCL_FILE_EVENTS then we do - * nothing. */ -) -{ - FileHandler *filePtr; - FileHandlerEvent *fileEvPtr; - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - for (filePtr = firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->mask != 0) { - filePtr->readyMask = Tcl_FileReady(filePtr->file, filePtr->mask); - if (filePtr->readyMask != 0) { - fileEvPtr = (FileHandlerEvent *) ckalloc( - sizeof(FileHandlerEvent)); - fileEvPtr->header.proc = FileHandlerEventProc; - fileEvPtr->file = filePtr->file; - Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * FileHandlerEventProc -- - * - * This procedure is called by Tcl_DoOneEvent when a file event - * reaches the front of the event queue. This procedure is responsible - * for actually handling the event by invoking the callback for the - * file handler. - * - * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_FILE_EVENTS flag bit isn't set. - * - * Side effects: - * Whatever the file handler's callback procedure does - * - *---------------------------------------------------------------------- - */ - -static int -FileHandlerEventProc( - Tcl_Event *evPtr, /* Event to service. */ - int flags /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ -) -{ - FileHandler *filePtr; - FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; - int mask; - - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } - - /* - * Search through the file handlers to find the one whose handle matches - * the event. We do this rather than keeping a pointer to the file - * handler directly in the event, so that the handler can be deleted - * while the event is queued without leaving a dangling pointer. - */ - - for (filePtr = firstFileHandlerPtr; filePtr != NULL; - filePtr = filePtr->nextPtr) { - if (filePtr->file != fileEvPtr->file) { - continue; - } - - /* - * The code is tricky for two reasons: - * 1. The file handler's desired events could have changed - * since the time when the event was queued, so AND the - * ready mask with the desired mask. - * 2. The file could have been closed and re-opened since - * the time when the event was queued. This is why the - * ready mask is stored in the file handler rather than - * the queued event: it will be zeroed when a new - * file handler is created for the newly opened file. - */ - - mask = filePtr->readyMask & filePtr->mask; - filePtr->readyMask = 0; - if (mask != 0) { - (*filePtr->proc)(filePtr->clientData, mask); - } - break; - } - return 1; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_CreateTimerHandler -- - * - * Arrange for a given procedure to be invoked at a particular - * time in the future. - * - * Results: - * The return value is a token for the timer event, which - * may be used to delete the event before it fires. - * - * Side effects: - * When milliseconds have elapsed, proc will be invoked - * exactly once. - * - *-------------------------------------------------------------- - */ - -Tcl_TimerToken -Tcl_CreateTimerHandler( - int milliseconds, /* How many milliseconds to wait - * before invoking proc. */ - Tcl_TimerProc *proc, /* Procedure to invoke. */ - ClientData clientData /* Arbitrary data to pass to proc. */ -) -{ - TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; - static int id = 0; - - if (!timerEventSourceCreated) { - timerEventSourceCreated = 1; - Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, - (ClientData) NULL); - Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL); - } - - timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); - - /* - * Compute when the event should fire. - */ - - TclGetTime(&timerHandlerPtr->time); - timerHandlerPtr->time.sec += milliseconds/1000; - timerHandlerPtr->time.usec += (milliseconds%1000)*1000; - if (timerHandlerPtr->time.usec >= 1000000) { - timerHandlerPtr->time.usec -= 1000000; - timerHandlerPtr->time.sec += 1; - } - - /* - * Fill in other fields for the event. - */ - - timerHandlerPtr->proc = proc; - timerHandlerPtr->clientData = clientData; - id++; - timerHandlerPtr->token = (Tcl_TimerToken) (intptr_t) id; - - /* - * Add the event to the queue in the correct position - * (ordered by event firing time). - */ - - for (tPtr2 = firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; - prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { - if ((tPtr2->time.sec > timerHandlerPtr->time.sec) - || ((tPtr2->time.sec == timerHandlerPtr->time.sec) - && (tPtr2->time.usec > timerHandlerPtr->time.usec))) { - break; - } - } - timerHandlerPtr->nextPtr = tPtr2; - if (prevPtr == NULL) { - firstTimerHandlerPtr = timerHandlerPtr; - } else { - prevPtr->nextPtr = timerHandlerPtr; - } - return timerHandlerPtr->token; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_DeleteTimerHandler -- - * - * Delete a previously-registered timer handler. - * - * Results: - * None. - * - * Side effects: - * Destroy the timer callback identified by TimerToken, - * so that its associated procedure will not be called. - * If the callback has already fired, or if the given - * token doesn't exist, then nothing happens. - * - *-------------------------------------------------------------- - */ - -void -Tcl_DeleteTimerHandler( - Tcl_TimerToken token /* Result previously returned by - * Tcl_DeleteTimerHandler. */ -) -{ - TimerHandler *timerHandlerPtr, *prevPtr; - - for (timerHandlerPtr = firstTimerHandlerPtr, prevPtr = NULL; - timerHandlerPtr != NULL; prevPtr = timerHandlerPtr, - timerHandlerPtr = timerHandlerPtr->nextPtr) { - if (timerHandlerPtr->token != token) { - continue; - } - if (prevPtr == NULL) { - firstTimerHandlerPtr = timerHandlerPtr->nextPtr; - } else { - prevPtr->nextPtr = timerHandlerPtr->nextPtr; - } - ckfree((char *) timerHandlerPtr); - return; - } -} - -/* - *-------------------------------------------------------------- - * - * Tcl_CreateModalTimeout -- - * - * Arrange for a given procedure to be invoked at a particular - * time in the future, independently of all other timer events. - * - * Results: - * None. - * - * Side effects: - * When milliseconds have elapsed, proc will be invoked - * exactly once. - * - *-------------------------------------------------------------- - */ - -void -Tcl_CreateModalTimeout( - int milliseconds, /* How many milliseconds to wait - * before invoking proc. */ - Tcl_TimerProc *proc, /* Procedure to invoke. */ - ClientData clientData /* Arbitrary data to pass to proc. */ -) -{ - TimerHandler *timerHandlerPtr; - - if (!timerEventSourceCreated) { - timerEventSourceCreated = 1; - Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, - (ClientData) NULL); - Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL); - } - - timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); - - /* - * Compute when the timeout should fire and fill in the other fields - * of the handler. - */ - - TclGetTime(&timerHandlerPtr->time); - timerHandlerPtr->time.sec += milliseconds/1000; - timerHandlerPtr->time.usec += (milliseconds%1000)*1000; - if (timerHandlerPtr->time.usec >= 1000000) { - timerHandlerPtr->time.usec -= 1000000; - timerHandlerPtr->time.sec += 1; - } - timerHandlerPtr->proc = proc; - timerHandlerPtr->clientData = clientData; - - /* - * Push the handler on the top of the modal stack. - */ - - timerHandlerPtr->nextPtr = firstModalHandlerPtr; - firstModalHandlerPtr = timerHandlerPtr; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_DeleteModalTimeout -- - * - * Remove the topmost modal timer handler from the stack of - * modal handlers. - * - * Results: - * None. - * - * Side effects: - * Destroys the topmost modal timeout handler, which must - * match proc and clientData. - * - *-------------------------------------------------------------- - */ - -void -Tcl_DeleteModalTimeout( - Tcl_TimerProc *proc, /* Callback procedure for the timeout. */ - ClientData clientData /* Arbitrary data to pass to proc. */ -) -{ - TimerHandler *timerHandlerPtr; - - timerHandlerPtr = firstModalHandlerPtr; - firstModalHandlerPtr = timerHandlerPtr->nextPtr; - if ((timerHandlerPtr->proc != proc) - || (timerHandlerPtr->clientData != clientData)) { - panic("Tcl_DeleteModalTimeout found timeout stack corrupted"); - } - ckfree((char *) timerHandlerPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TimerHandlerSetupProc -- - * - * This procedure is part of the "event source" for timers. - * It is invoked by Tcl_DoOneEvent before it calls select (or - * whatever it uses to wait). - * - * Results: - * None. - * - * Side effects: - * Tells the notifier how long to sleep if it decides to block. - * - *---------------------------------------------------------------------- - */ - -static void -TimerHandlerSetupProc( - ClientData clientData, /* Not used. */ - int flags /* Flags passed to Tk_DoOneEvent: - * if it doesn't include - * TCL_TIMER_EVENTS then we only - * consider modal timers. */ -) -{ - TimerHandler *timerHandlerPtr, *tPtr2; - Tcl_Time blockTime; - - /* - * Find the timer handler (regular or modal) that fires first. - */ - - timerHandlerPtr = firstTimerHandlerPtr; - if (!(flags & TCL_TIMER_EVENTS)) { - timerHandlerPtr = NULL; - } - if (timerHandlerPtr != NULL) { - tPtr2 = firstModalHandlerPtr; - if (tPtr2 != NULL) { - if ((timerHandlerPtr->time.sec > tPtr2->time.sec) - || ((timerHandlerPtr->time.sec == tPtr2->time.sec) - && (timerHandlerPtr->time.usec > tPtr2->time.usec))) { - timerHandlerPtr = tPtr2; - } - } - } else { - timerHandlerPtr = firstModalHandlerPtr; - } - if (timerHandlerPtr == NULL) { - return; - } - - TclGetTime(&blockTime); - blockTime.sec = timerHandlerPtr->time.sec - blockTime.sec; - blockTime.usec = timerHandlerPtr->time.usec - blockTime.usec; - if (blockTime.usec < 0) { - blockTime.sec -= 1; - blockTime.usec += 1000000; - } - if (blockTime.sec < 0) { - blockTime.sec = 0; - blockTime.usec = 0; - } - Tcl_SetMaxBlockTime(&blockTime); -} - -/* - *---------------------------------------------------------------------- - * - * TimerHandlerCheckProc -- - * - * This procedure is the second part of the "event source" for - * file handlers. It is invoked by Tcl_DoOneEvent after it calls - * select (or whatever it uses to wait for events). - * - * Results: - * None. - * - * Side effects: - * Makes entries on the Tcl event queue for each file that is - * now ready. - * - *---------------------------------------------------------------------- - */ - -static void -TimerHandlerCheckProc( - ClientData clientData, /* Not used. */ - int flags /* Flags passed to Tk_DoOneEvent: - * if it doesn't include - * TCL_TIMER_EVENTS then we only - * consider modal timeouts. */ -) -{ - TimerHandler *timerHandlerPtr; - TimerEvent *timerEvPtr; - int triggered, gotTime; - Tcl_Time curTime; - - triggered = 0; - gotTime = 0; - timerHandlerPtr = firstTimerHandlerPtr; - if ((flags & TCL_TIMER_EVENTS) && (timerHandlerPtr != NULL)) { - TclGetTime(&curTime); - gotTime = 1; - if ((timerHandlerPtr->time.sec < curTime.sec) - || ((timerHandlerPtr->time.sec == curTime.sec) - && (timerHandlerPtr->time.usec <= curTime.usec))) { - triggered = 1; - } - } - timerHandlerPtr = firstModalHandlerPtr; - if (timerHandlerPtr != NULL) { - if (!gotTime) { - TclGetTime(&curTime); - } - if ((timerHandlerPtr->time.sec < curTime.sec) - || ((timerHandlerPtr->time.sec == curTime.sec) - && (timerHandlerPtr->time.usec <= curTime.usec))) { - triggered = 1; - } - } - if (triggered) { - timerEvPtr = (TimerEvent *) ckalloc(sizeof(TimerEvent)); - timerEvPtr->header.proc = TimerHandlerEventProc; - timerEvPtr->time.sec = curTime.sec; - timerEvPtr->time.usec = curTime.usec; - Tcl_QueueEvent((Tcl_Event *) timerEvPtr, TCL_QUEUE_TAIL); - } -} - -/* - *---------------------------------------------------------------------- - * - * TimerHandlerExitProc -- - * - * Callback invoked during exit cleanup to destroy the timer event - * source. - * - * Results: - * None. - * - * Side effects: - * Destroys the timer event source. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -TimerHandlerExitProc( - ClientData clientData /* Not used. */ -) -{ - Tcl_DeleteEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, - (ClientData) NULL); -} - -/* - *---------------------------------------------------------------------- - * - * TimerHandlerEventProc -- - * - * This procedure is called by Tcl_DoOneEvent when a timer event - * reaches the front of the event queue. This procedure handles - * the event by invoking the callbacks for all timers that are - * ready. - * - * Results: - * Returns 1 if the event was handled, meaning it should be removed - * from the queue. Returns 0 if the event was not handled, meaning - * it should stay on the queue. The only time the event isn't - * handled is if the TCL_TIMER_EVENTS flag bit isn't set. - * - * Side effects: - * Whatever the timer handler callback procedures do. - * - *---------------------------------------------------------------------- - */ - -static int -TimerHandlerEventProc( - Tcl_Event *evPtr, /* Event to service. */ - int flags /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ -) -{ - TimerHandler *timerHandlerPtr; - TimerEvent *timerEvPtr = (TimerEvent *) evPtr; - - /* - * Invoke the current modal timeout first, if there is one and - * it has triggered. - */ - - timerHandlerPtr = firstModalHandlerPtr; - if (firstModalHandlerPtr != NULL) { - if ((timerHandlerPtr->time.sec < timerEvPtr->time.sec) - || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec) - && (timerHandlerPtr->time.usec <= timerEvPtr->time.usec))) { - (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); - } - } - - /* - * Invoke any normal timers that have fired. - */ - - if (!(flags & TCL_TIMER_EVENTS)) { - return 1; - } - - while (1) { - timerHandlerPtr = firstTimerHandlerPtr; - if (timerHandlerPtr == NULL) { - break; - } - if ((timerHandlerPtr->time.sec > timerEvPtr->time.sec) - || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec) - && (timerHandlerPtr->time.usec >= timerEvPtr->time.usec))) { - break; - } - - /* - * Remove the handler from the queue before invoking it, - * to avoid potential reentrancy problems. - */ - - firstTimerHandlerPtr = timerHandlerPtr->nextPtr; - (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); - ckfree((char *) timerHandlerPtr); - } - return 1; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_DoWhenIdle -- - * - * Arrange for proc to be invoked the next time the system is - * idle (i.e., just before the next time that Tcl_DoOneEvent - * would have to wait for something to happen). - * - * Results: - * None. - * - * Side effects: - * Proc will eventually be called, with clientData as argument. - * See the manual entry for details. - * - *-------------------------------------------------------------- - */ - -void -Tcl_DoWhenIdle( - Tcl_IdleProc *proc, /* Procedure to invoke. */ - ClientData clientData /* Arbitrary value to pass to proc. */ -) -{ - IdleHandler *idlePtr; - - idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler)); - idlePtr->proc = proc; - idlePtr->clientData = clientData; - idlePtr->generation = idleGeneration; - idlePtr->nextPtr = NULL; - if (lastIdlePtr == NULL) { - idleList = idlePtr; - } else { - lastIdlePtr->nextPtr = idlePtr; - } - lastIdlePtr = idlePtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CancelIdleCall -- - * - * If there are any when-idle calls requested to a given procedure - * with given clientData, cancel all of them. - * - * Results: - * None. - * - * Side effects: - * If the proc/clientData combination were on the when-idle list, - * they are removed so that they will never be called. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CancelIdleCall( - Tcl_IdleProc *proc, /* Procedure that was previously registered. */ - ClientData clientData /* Arbitrary value to pass to proc. */ -) -{ - IdleHandler *idlePtr, *prevPtr; - IdleHandler *nextPtr; - - for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL; - prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) { - while ((idlePtr->proc == proc) - && (idlePtr->clientData == clientData)) { - nextPtr = idlePtr->nextPtr; - ckfree((char *) idlePtr); - idlePtr = nextPtr; - if (prevPtr == NULL) { - idleList = idlePtr; - } else { - prevPtr->nextPtr = idlePtr; - } - if (idlePtr == NULL) { - lastIdlePtr = prevPtr; - return; - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclIdlePending -- - * - * This function is called by the notifier subsystem to determine - * whether there are any idle handlers currently scheduled. - * - * Results: - * Returns 0 if the idle list is empty, otherwise it returns 1. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclIdlePending(void) -{ - return (idleList == NULL) ? 0 : 1; -} - -/* - *---------------------------------------------------------------------- - * - * TclServiceIdle -- - * - * This procedure is invoked by the notifier when it becomes idle. - * - * Results: - * The return value is 1 if the procedure actually found an idle - * handler to invoke. If no handler was found then 0 is returned. - * - * Side effects: - * Invokes all pending idle handlers. - * - *---------------------------------------------------------------------- - */ - -int -TclServiceIdle(void) -{ - IdleHandler *idlePtr; - int oldGeneration; - int foundIdle; - - if (idleList == NULL) { - return 0; - } - - foundIdle = 0; - oldGeneration = idleGeneration; - idleGeneration++; - - /* - * The code below is trickier than it may look, for the following - * reasons: - * - * 1. New handlers can get added to the list while the current - * one is being processed. If new ones get added, we don't - * want to process them during this pass through the list (want - * to check for other work to do first). This is implemented - * using the generation number in the handler: new handlers - * will have a different generation than any of the ones currently - * on the list. - * 2. The handler can call Tcl_DoOneEvent, so we have to remove - * the handler from the list before calling it. Otherwise an - * infinite loop could result. - * 3. Tcl_CancelIdleCall can be called to remove an element from - * the list while a handler is executing, so the list could - * change structure during the call. - */ - - for (idlePtr = idleList; - ((idlePtr != NULL) - && ((oldGeneration - idlePtr->generation) >= 0)); - idlePtr = idleList) { - idleList = idlePtr->nextPtr; - if (idleList == NULL) { - lastIdlePtr = NULL; - } - foundIdle = 1; - (*idlePtr->proc)(idlePtr->clientData); - ckfree((char *) idlePtr); - } - - return foundIdle; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_BackgroundError -- - * - * This procedure is invoked to handle errors that occur in Tcl - * commands that are invoked in "background" (e.g. from event or - * timer bindings). - * - * Results: - * None. - * - * Side effects: - * The command "bgerror" is invoked later as an idle handler to - * process the error, passing it the error message. If that fails, - * then an error message is output on stderr. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_BackgroundError( - Tcl_Interp *interp /* Interpreter in which an error has - * occurred. */ -) -{ - BgError *errPtr; - char *varValue; - ErrAssocData *assocPtr; - - /* - * The Tcl_AddErrorInfo call below (with an empty string) ensures that - * errorInfo gets properly set. It's needed in cases where the error - * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval; - * in these cases errorInfo still won't have been set when this - * procedure is called. - */ - - Tcl_AddErrorInfo(interp, ""); - errPtr = (BgError *) ckalloc(sizeof(BgError)); - errPtr->interp = interp; - errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(interp->result) - + 1)); - strcpy(errPtr->errorMsg, interp->result); - varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); - if (varValue == NULL) { - varValue = errPtr->errorMsg; - } - errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); - strcpy(errPtr->errorInfo, varValue); - varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); - if (varValue == NULL) { - varValue = ""; - } - errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); - strcpy(errPtr->errorCode, varValue); - errPtr->nextPtr = NULL; - - assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", - (Tcl_InterpDeleteProc **) NULL); - if (assocPtr == NULL) { - - /* - * This is the first time a background error has occurred in - * this interpreter. Create associated data to keep track of - * pending error reports. - */ - - assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); - assocPtr->firstBgPtr = NULL; - assocPtr->lastBgPtr = NULL; - Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, - (ClientData) assocPtr); - } - if (assocPtr->firstBgPtr == NULL) { - assocPtr->firstBgPtr = errPtr; - Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr); - } else { - assocPtr->lastBgPtr->nextPtr = errPtr; - } - assocPtr->lastBgPtr = errPtr; - Tcl_ResetResult(interp); -} - -/* - *---------------------------------------------------------------------- - * - * HandleBgErrors -- - * - * This procedure is invoked as an idle handler to process all of - * the accumulated background errors. - * - * Results: - * None. - * - * Side effects: - * Depends on what actions "bgerror" takes for the errors. - * - *---------------------------------------------------------------------- - */ - -static void -HandleBgErrors( - ClientData clientData /* Pointer to ErrAssocData structure. */ -) -{ - Tcl_Interp *interp; - char *command; - char *argv[2]; - int code; - BgError *errPtr; - ErrAssocData *assocPtr = (ErrAssocData *) clientData; - Tcl_Channel errChannel; - - while (assocPtr->firstBgPtr != NULL) { - interp = assocPtr->firstBgPtr->interp; - if (interp == NULL) { - goto doneWithReport; - } - - /* - * Restore important state variables to what they were at - * the time the error occurred. - */ - - Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo, - TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode, - TCL_GLOBAL_ONLY); - - /* - * Create and invoke the bgerror command. - */ - - argv[0] = "bgerror"; - argv[1] = assocPtr->firstBgPtr->errorMsg; - command = Tcl_Merge(2, argv); - Tcl_AllowExceptions(interp); - Tcl_Preserve((ClientData) interp); - code = Tcl_GlobalEval(interp, command); - ckfree(command); - if (code == TCL_ERROR) { - - /* - * We have to get the error output channel at the latest possible - * time, because the eval (above) might have changed the channel. - */ - - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel != (Tcl_Channel) NULL) { - if (strcmp(interp->result, - "\"bgerror\" is an invalid command name or ambiguous abbreviation") - == 0) { - Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1); - Tcl_Write(errChannel, "\n", -1); - } else { - Tcl_Write(errChannel, - "bgerror failed to handle background error.\n", - -1); - Tcl_Write(errChannel, " Original error: ", -1); - Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg, - -1); - Tcl_Write(errChannel, "\n", -1); - Tcl_Write(errChannel, " Error in bgerror: ", -1); - Tcl_Write(errChannel, interp->result, -1); - Tcl_Write(errChannel, "\n", -1); - } - Tcl_Flush(errChannel); - } - } else if (code == TCL_BREAK) { - - /* - * Break means cancel any remaining error reports for this - * interpreter. - */ - - for (errPtr = assocPtr->firstBgPtr; errPtr != NULL; - errPtr = errPtr->nextPtr) { - if (errPtr->interp == interp) { - errPtr->interp = NULL; - } - } - } - - Tcl_Release((ClientData) interp); - - /* - * Discard the command and the information about the error report. - */ - - doneWithReport: - ckfree(assocPtr->firstBgPtr->errorMsg); - ckfree(assocPtr->firstBgPtr->errorInfo); - ckfree(assocPtr->firstBgPtr->errorCode); - errPtr = assocPtr->firstBgPtr->nextPtr; - ckfree((char *) assocPtr->firstBgPtr); - assocPtr->firstBgPtr = errPtr; - } - assocPtr->lastBgPtr = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * BgErrorDeleteProc -- - * - * This procedure is associated with the "tclBgError" assoc data - * for an interpreter; it is invoked when the interpreter is - * deleted in order to free the information assoicated with any - * pending error reports. - * - * Results: - * None. - * - * Side effects: - * Background error information is freed: if there were any - * pending error reports, they are cancelled. - * - *---------------------------------------------------------------------- - */ - -static void -BgErrorDeleteProc( - ClientData clientData, /* Pointer to ErrAssocData structure. */ - Tcl_Interp *interp /* Interpreter being deleted. */ -) -{ - ErrAssocData *assocPtr = (ErrAssocData *) clientData; - BgError *errPtr; - - while (assocPtr->firstBgPtr != NULL) { - errPtr = assocPtr->firstBgPtr; - assocPtr->firstBgPtr = errPtr->nextPtr; - ckfree(errPtr->errorMsg); - ckfree(errPtr->errorInfo); - ckfree(errPtr->errorCode); - ckfree((char *) errPtr); - } - ckfree((char *) assocPtr); - Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateExitHandler -- - * - * Arrange for a given procedure to be invoked just before the - * application exits. - * - * Results: - * None. - * - * Side effects: - * Proc will be invoked with clientData as argument when the - * application exits. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CreateExitHandler( - Tcl_ExitProc *proc, /* Procedure to invoke. */ - ClientData clientData /* Arbitrary value to pass to proc. */ -) -{ - ExitHandler *exitPtr; - - exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); - exitPtr->proc = proc; - exitPtr->clientData = clientData; - exitPtr->nextPtr = firstExitPtr; - firstExitPtr = exitPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteExitHandler -- - * - * This procedure cancels an existing exit handler matching proc - * and clientData, if such a handler exits. - * - * Results: - * None. - * - * Side effects: - * If there is an exit handler corresponding to proc and clientData - * then it is cancelled; if no such handler exists then nothing - * happens. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteExitHandler( - Tcl_ExitProc *proc, /* Procedure that was previously registered. */ - ClientData clientData /* Arbitrary value to pass to proc. */ -) -{ - ExitHandler *exitPtr, *prevPtr; - - for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; - prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { - if ((exitPtr->proc == proc) - && (exitPtr->clientData == clientData)) { - if (prevPtr == NULL) { - firstExitPtr = exitPtr->nextPtr; - } else { - prevPtr->nextPtr = exitPtr->nextPtr; - } - ckfree((char *) exitPtr); - return; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Exit -- - * - * This procedure is called to terminate the application. - * - * Results: - * None. - * - * Side effects: - * All existing exit handlers are invoked, then the application - * ends. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_Exit( - int status /* Exit status for application; typically - * 0 for normal return, 1 for error return. */ -) -{ - ExitHandler *exitPtr; - - for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { - /* - * Be careful to remove the handler from the list before invoking - * its callback. This protects us against double-freeing if the - * callback should call Tcl_DeleteExitHandler on itself. - */ - - firstExitPtr = exitPtr->nextPtr; - (*exitPtr->proc)(exitPtr->clientData); - ckfree((char *) exitPtr); - } -#ifdef TCL_MEM_DEBUG - if (tclMemDumpFileName != NULL) { - Tcl_DumpActiveMemory(tclMemDumpFileName); - } -#endif - - TclPlatformExit(status); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AfterCmd -- - * - * This procedure is invoked to process the "after" 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_AfterCmd( - ClientData clientData, /* Points to the "tclAfter" assocData for - * this interpreter, or NULL if the assocData - * hasn't been created yet.*/ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - /* - * The variable below is used to generate unique identifiers for - * after commands. This id can wrap around, which can potentially - * cause problems. However, there are not likely to be problems - * in practice, because after commands can only be requested to - * about a month in the future, and wrap-around is unlikely to - * occur in less than about 1-10 years. Thus it's unlikely that - * any old ids will still be around when wrap-around occurs. - */ - - static int nextId = 1; - int ms; - AfterInfo *afterPtr; - AfterAssocData *assocPtr = (AfterAssocData *) clientData; - Tcl_CmdInfo cmdInfo; - size_t length; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option ?arg arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * Create the "after" information associated for this interpreter, - * if it doesn't already exist. Associate it with the command too, - * so that it will be passed in as the ClientData argument in the - * future. - */ - - if (assocPtr == NULL) { - assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); - assocPtr->interp = interp; - assocPtr->firstAfterPtr = NULL; - Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, - (ClientData) assocPtr); - cmdInfo.proc = Tcl_AfterCmd; - cmdInfo.clientData = (ClientData) assocPtr; - cmdInfo.deleteProc = NULL; - cmdInfo.deleteData = (ClientData) assocPtr; - Tcl_SetCommandInfo(interp, argv[0], &cmdInfo); - } - - /* - * Parse the command. - */ - - length = strlen(argv[1]); - if (isdigit(UCHAR(argv[1][0]))) { - if (Tcl_GetInt(interp, argv[1], &ms) != TCL_OK) { - return TCL_ERROR; - } - if (ms < 0) { - ms = 0; - } - if (argc == 2) { - Tcl_Sleep(ms); - return TCL_OK; - } - afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); - afterPtr->assocPtr = assocPtr; - if (argc == 3) { - afterPtr->command = (char *) ckalloc((unsigned) - (strlen(argv[2]) + 1)); - strcpy(afterPtr->command, argv[2]); - } else { - afterPtr->command = Tcl_Concat(argc-2, argv+2); - } - afterPtr->id = nextId; - nextId += 1; - afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, - (ClientData) afterPtr); - afterPtr->nextPtr = assocPtr->firstAfterPtr; - assocPtr->firstAfterPtr = afterPtr; - sprintf(interp->result, "after#%d", afterPtr->id); - } else if (strncmp(argv[1], "cancel", length) == 0) { - char *arg; - - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " cancel id|command\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - arg = argv[2]; - } else { - arg = Tcl_Concat(argc-2, argv+2); - } - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - if (strcmp(afterPtr->command, arg) == 0) { - break; - } - } - if (afterPtr == NULL) { - afterPtr = GetAfterEvent(assocPtr, arg); - } - if (arg != argv[2]) { - ckfree(arg); - } - if (afterPtr != NULL) { - if (afterPtr->token != NULL) { - Tcl_DeleteTimerHandler(afterPtr->token); - } else { - Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); - } - FreeAfterPtr(afterPtr); - } - } else if ((strncmp(argv[1], "idle", length) == 0) - && (length >= 2)) { - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " idle script script ...\"", (char *) NULL); - return TCL_ERROR; - } - afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); - afterPtr->assocPtr = assocPtr; - if (argc == 3) { - afterPtr->command = (char *) ckalloc((unsigned) - (strlen(argv[2]) + 1)); - strcpy(afterPtr->command, argv[2]); - } else { - afterPtr->command = Tcl_Concat(argc-2, argv+2); - } - afterPtr->id = nextId; - nextId += 1; - afterPtr->token = NULL; - afterPtr->nextPtr = assocPtr->firstAfterPtr; - assocPtr->firstAfterPtr = afterPtr; - Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); - sprintf(interp->result, "after#%d", afterPtr->id); - } else if ((strncmp(argv[1], "info", length) == 0) - && (length >= 2)) { - if (argc == 2) { - char buffer[30]; - - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - if (assocPtr->interp == interp) { - sprintf(buffer, "after#%d", afterPtr->id); - Tcl_AppendElement(interp, buffer); - } - } - return TCL_OK; - } - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " info ?id?\"", (char *) NULL); - return TCL_ERROR; - } - afterPtr = GetAfterEvent(assocPtr, argv[2]); - if (afterPtr == NULL) { - Tcl_AppendResult(interp, "event \"", argv[2], - "\" doesn't exist", (char *) NULL); - return TCL_ERROR; - } - Tcl_AppendElement(interp, afterPtr->command); - Tcl_AppendElement(interp, - (afterPtr->token == NULL) ? "idle" : "timer"); - } else { - Tcl_AppendResult(interp, "bad argument \"", argv[1], - "\": must be cancel, idle, info, or a number", - (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * GetAfterEvent -- - * - * This procedure parses an "after" id such as "after#4" and - * returns a pointer to the AfterInfo structure. - * - * Results: - * The return value is either a pointer to an AfterInfo structure, - * if one is found that corresponds to "string" and is for interp, - * or NULL if no corresponding after event can be found. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static AfterInfo * -GetAfterEvent( - AfterAssocData *assocPtr, /* Points to "after"-related information for - * this interpreter. */ - char *string /* Textual identifier for after event, such - * as "after#6". */ -) -{ - AfterInfo *afterPtr; - int id; - char *end; - - if (strncmp(string, "after#", 6) != 0) { - return NULL; - } - string += 6; - id = strtoul(string, &end, 10); - if ((end == string) || (*end != 0)) { - return NULL; - } - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - if (afterPtr->id == id) { - return afterPtr; - } - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * AfterProc -- - * - * Timer callback to execute commands registered with the - * "after" command. - * - * Results: - * None. - * - * Side effects: - * Executes whatever command was specified. If the command - * returns an error, then the command "bgerror" is invoked - * to process the error; if bgerror fails then information - * about the error is output on stderr. - * - *---------------------------------------------------------------------- - */ - -static void -AfterProc( - ClientData clientData /* Describes command to execute. */ -) -{ - AfterInfo *afterPtr = (AfterInfo *) clientData; - AfterAssocData *assocPtr = afterPtr->assocPtr; - AfterInfo *prevPtr; - int result; - Tcl_Interp *interp; - - /* - * First remove the callback from our list of callbacks; otherwise - * someone could delete the callback while it's being executed, which - * could cause a core dump. - */ - - if (assocPtr->firstAfterPtr == afterPtr) { - assocPtr->firstAfterPtr = afterPtr->nextPtr; - } else { - for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr; - prevPtr = prevPtr->nextPtr) { - /* Empty loop body. */ - } - prevPtr->nextPtr = afterPtr->nextPtr; - } - - /* - * Execute the callback. - */ - - interp = assocPtr->interp; - Tcl_Preserve((ClientData) interp); - result = Tcl_GlobalEval(interp, afterPtr->command); - if (result != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); - Tcl_BackgroundError(interp); - } - Tcl_Release((ClientData) interp); - - /* - * Free the memory for the callback. - */ - - ckfree(afterPtr->command); - ckfree((char *) afterPtr); -} - -/* - *---------------------------------------------------------------------- - * - * FreeAfterPtr -- - * - * This procedure removes an "after" command from the list of - * those that are pending and frees its resources. This procedure - * does *not* cancel the timer handler; if that's needed, the - * caller must do it. - * - * Results: - * None. - * - * Side effects: - * The memory associated with afterPtr is released. - * - *---------------------------------------------------------------------- - */ - -static void -FreeAfterPtr( - AfterInfo *afterPtr /* Command to be deleted. */ -) -{ - AfterInfo *prevPtr; - AfterAssocData *assocPtr = afterPtr->assocPtr; - - if (assocPtr->firstAfterPtr == afterPtr) { - assocPtr->firstAfterPtr = afterPtr->nextPtr; - } else { - for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr; - prevPtr = prevPtr->nextPtr) { - /* Empty loop body. */ - } - prevPtr->nextPtr = afterPtr->nextPtr; - } - ckfree(afterPtr->command); - ckfree((char *) afterPtr); -} - -/* - *---------------------------------------------------------------------- - * - * AfterCleanupProc -- - * - * This procedure is invoked whenever an interpreter is deleted - * to cleanup the AssocData for "tclAfter". - * - * Results: - * None. - * - * Side effects: - * After commands are removed. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -AfterCleanupProc( - ClientData clientData, /* Points to AfterAssocData for the - * interpreter. */ - Tcl_Interp *interp /* Interpreter that is being deleted. */ -) -{ - AfterAssocData *assocPtr = (AfterAssocData *) clientData; - AfterInfo *afterPtr; - - while (assocPtr->firstAfterPtr != NULL) { - afterPtr = assocPtr->firstAfterPtr; - assocPtr->firstAfterPtr = afterPtr->nextPtr; - if (afterPtr->token != NULL) { - Tcl_DeleteTimerHandler(afterPtr->token); - } else { - Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); - } - ckfree(afterPtr->command); - ckfree((char *) afterPtr); - } - ckfree((char *) assocPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_VwaitCmd -- - * - * This procedure is invoked to process the "vwait" 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_VwaitCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int done, foundEvent; - - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " name\"", (char *) NULL); - return TCL_ERROR; - } - Tcl_TraceVar(interp, argv[1], - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, (ClientData) &done); - done = 0; - foundEvent = 1; - while (!done && foundEvent) { - foundEvent = Tcl_DoOneEvent(0); - } - Tcl_UntraceVar(interp, argv[1], - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, (ClientData) &done); - - /* - * Clear out the interpreter's result, since it may have been set - * by event handlers. - */ - - Tcl_ResetResult(interp); - if (!foundEvent) { - Tcl_AppendResult(interp, "can't wait for variable \"", argv[1], - "\": would wait forever", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - - /* ARGSUSED */ -static char * -VwaitVarProc( - ClientData clientData, /* Pointer to integer to set to 1. */ - Tcl_Interp *interp, /* Interpreter containing variable. */ - char *name1, /* Name of variable. */ - char *name2, /* Second part of variable name. */ - int flags /* Information about what happened. */ -) -{ - int *donePtr = (int *) clientData; - - *donePtr = 1; - return (char *) NULL; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UpdateCmd -- - * - * This procedure is invoked to process the "update" 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_UpdateCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int flags = 0; /* Initialization needed only to stop - * compiler warnings. */ - - if (argc == 1) { - flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; - } else if (argc == 2) { - if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be idletasks", (char *) NULL); - return TCL_ERROR; - } - flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; - } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ?idletasks?\"", (char *) NULL); - return TCL_ERROR; - } - - while (Tcl_DoOneEvent(flags) != 0) { - /* Empty loop body */ - } - - /* - * Must clear the interpreter's result because event handlers could - * have executed commands. - */ - - Tcl_ResetResult(interp); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclWaitForFile -- - * - * This procedure waits synchronously for a file to become readable - * or writable, with an optional timeout. - * - * Results: - * The return value is an OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions - * that are present on file at the time of the return. This - * procedure will not return until either "timeout" milliseconds - * have elapsed or at least one of the conditions given by mask - * has occurred for file (a return value of 0 means that a timeout - * occurred). No normal events will be serviced during the - * execution of this procedure. - * - * Side effects: - * Time passes. - * - *---------------------------------------------------------------------- - */ - -int -TclWaitForFile( - Tcl_File file, /* Handle for file on which to wait. */ - int mask, /* What to wait for: OR'ed combination of - * TCL_READABLE, TCL_WRITABLE, and - * TCL_EXCEPTION. */ - int timeout /* Maximum amount of time to wait for one - * of the conditions in mask to occur, in - * milliseconds. A value of 0 means don't - * wait at all, and a value of -1 means - * wait forever. */ -) -{ - Tcl_Time abortTime, now, blockTime; - int present; - - /* - * If there is a non-zero finite timeout, compute the time when - * we give up. - */ - - if (timeout > 0) { - TclGetTime(&now); - abortTime.sec = now.sec + timeout/1000; - abortTime.usec = now.usec + (timeout%1000)*1000; - if (abortTime.usec >= 1000000) { - abortTime.usec -= 1000000; - abortTime.sec += 1; - } - } - - /* - * Loop in a mini-event loop of our own, waiting for either the - * file to become ready or a timeout to occur. - */ - - while (1) { - Tcl_WatchFile(file, mask); - if (timeout > 0) { - blockTime.sec = abortTime.sec - now.sec; - blockTime.usec = abortTime.usec - now.usec; - if (blockTime.usec < 0) { - blockTime.sec -= 1; - blockTime.usec += 1000000; - } - if (blockTime.sec < 0) { - blockTime.sec = 0; - blockTime.usec = 0; - } - Tcl_WaitForEvent(&blockTime); - } else if (timeout == 0) { - blockTime.sec = 0; - blockTime.usec = 0; - Tcl_WaitForEvent(&blockTime); - } else { - Tcl_WaitForEvent((Tcl_Time *) NULL); - } - present = Tcl_FileReady(file, mask); - if (present != 0) { - break; - } - if (timeout == 0) { - break; - } - TclGetTime(&now); - if ((abortTime.sec < now.sec) - || ((abortTime.sec == now.sec) - && (abortTime.usec <= now.usec))) { - break; - } - } - return present; -} diff --git a/cde/programs/dtdocbook/tcl/tclExpr.c b/cde/programs/dtdocbook/tcl/tclExpr.c deleted file mode 100644 index 85f4832d..00000000 --- a/cde/programs/dtdocbook/tcl/tclExpr.c +++ /dev/null @@ -1,2105 +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: tclExpr.c /main/2 1996/08/08 14:43:48 cde-hp $ */ -/* - * tclExpr.c -- - * - * This file contains the code to evaluate expressions for - * Tcl. - * - * This implementation of floating-point support was modelled - * after an initial implementation by Bill Carpenter. - * - * Copyright (c) 1987-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: @(#) tclExpr.c 1.91 96/02/15 11:42:44 - */ - -#include "tclInt.h" -#ifdef NO_FLOAT_H -# include "../compat/float.h" -#else -# include -#endif -#ifndef TCL_NO_MATH -#include -#endif - -/* - * The stuff below is a bit of a hack so that this file can be used - * in environments that include no UNIX, i.e. no errno. Just define - * errno here. - */ - -#ifndef TCL_GENERIC_ONLY -#include "tclPort.h" -#else -#define NO_ERRNO_H -#endif - -#ifdef NO_ERRNO_H -int errno; -#define EDOM 33 -#define ERANGE 34 -#endif - -/* - * The data structure below is used to describe an expression value, - * which can be either an integer (the usual case), a double-precision - * floating-point value, or a string. A given number has only one - * value at a time. - */ - -#define STATIC_STRING_SPACE 150 - -typedef struct { - long intValue; /* Integer value, if any. */ - double doubleValue; /* Floating-point value, if any. */ - ParseValue pv; /* Used to hold a string value, if any. */ - char staticSpace[STATIC_STRING_SPACE]; - /* Storage for small strings; large ones - * are malloc-ed. */ - int type; /* Type of value: TYPE_INT, TYPE_DOUBLE, - * or TYPE_STRING. */ -} Value; - -/* - * Valid values for type: - */ - -#define TYPE_INT 0 -#define TYPE_DOUBLE 1 -#define TYPE_STRING 2 - -/* - * The data structure below describes the state of parsing an expression. - * It's passed among the routines in this module. - */ - -typedef struct { - char *originalExpr; /* The entire expression, as originally - * passed to Tcl_ExprString et al. */ - char *expr; /* Position to the next character to be - * scanned from the expression string. */ - int token; /* Type of the last token to be parsed from - * expr. See below for definitions. - * Corresponds to the characters just - * before expr. */ -} ExprInfo; - -/* - * The token types are defined below. In addition, there is a table - * associating a precedence with each operator. The order of types - * is important. Consult the code before changing it. - */ - -#define VALUE 0 -#define OPEN_PAREN 1 -#define CLOSE_PAREN 2 -#define COMMA 3 -#define END 4 -#define UNKNOWN 5 - -/* - * Binary operators: - */ - -#define MULT 8 -#define DIVIDE 9 -#define MOD 10 -#define PLUS 11 -#define MINUS 12 -#define LEFT_SHIFT 13 -#define RIGHT_SHIFT 14 -#define LESS 15 -#define GREATER 16 -#define LEQ 17 -#define GEQ 18 -#define EQUAL 19 -#define NEQ 20 -#define BIT_AND 21 -#define BIT_XOR 22 -#define BIT_OR 23 -#define AND 24 -#define OR 25 -#define QUESTY 26 -#define COLON 27 - -/* - * Unary operators: - */ - -#define UNARY_MINUS 28 -#define UNARY_PLUS 29 -#define NOT 30 -#define BIT_NOT 31 - -/* - * Precedence table. The values for non-operator token types are ignored. - */ - -static int precTable[] = { - 0, 0, 0, 0, 0, 0, 0, 0, - 12, 12, 12, /* MULT, DIVIDE, MOD */ - 11, 11, /* PLUS, MINUS */ - 10, 10, /* LEFT_SHIFT, RIGHT_SHIFT */ - 9, 9, 9, 9, /* LESS, GREATER, LEQ, GEQ */ - 8, 8, /* EQUAL, NEQ */ - 7, /* BIT_AND */ - 6, /* BIT_XOR */ - 5, /* BIT_OR */ - 4, /* AND */ - 3, /* OR */ - 2, /* QUESTY */ - 1, /* COLON */ - 13, 13, 13, 13 /* UNARY_MINUS, UNARY_PLUS, NOT, - * BIT_NOT */ -}; - -/* - * Mapping from operator numbers to strings; used for error messages. - */ - -static char *operatorStrings[] = { - "VALUE", "(", ")", ",", "END", "UNKNOWN", "6", "7", - "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=", - ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":", - "-", "+", "!", "~" -}; - -/* - * The following slight modification to DBL_MAX is needed because of - * a compiler bug on Sprite (4/15/93). - */ - -#ifdef sprite -#undef DBL_MAX -#define DBL_MAX 1.797693134862316e+307 -#endif - -/* - * Macros for testing floating-point values for certain special - * cases. Test for not-a-number by comparing a value against - * itself; test for infinity by comparing against the largest - * floating-point value. - */ - -#define IS_NAN(v) ((v) != (v)) -#ifdef DBL_MAX -# define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) -#else -# define IS_INF(v) 0 -#endif - -/* - * The following global variable is use to signal matherr that Tcl - * is responsible for the arithmetic, so errors can be handled in a - * fashion appropriate for Tcl. Zero means no Tcl math is in - * progress; non-zero means Tcl is doing math. - */ - -int tcl_MathInProgress = 0; - -/* - * The variable below serves no useful purpose except to generate - * a reference to matherr, so that the Tcl version of matherr is - * linked in rather than the system version. Without this reference - * the need for matherr won't be discovered during linking until after - * libtcl.a has been processed, so Tcl's version won't be used. - */ - -#ifdef NEED_MATHERR -extern int matherr(); -int (*tclMatherrPtr)() = matherr; -#endif - -/* - * Declarations for local procedures to this file: - */ - -static int ExprAbsFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr)); -static int ExprBinaryFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr)); -static int ExprDoubleFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr)); -static int ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int prec, Value *valuePtr)); -static int ExprIntFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr)); -static int ExprLex _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, Value *valuePtr)); -static int ExprLooksLikeInt _ANSI_ARGS_((char *p)); -static void ExprMakeString _ANSI_ARGS_((Tcl_Interp *interp, - Value *valuePtr)); -static int ExprMathFunc _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, Value *valuePtr)); -static int ExprParseString _ANSI_ARGS_((Tcl_Interp *interp, - char *string, Value *valuePtr)); -static int ExprRoundFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr)); -static int ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp, - char *string, Value *valuePtr)); -static int ExprUnaryFunc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr)); - -/* - * Built-in math functions: - */ - -typedef struct { - char *name; /* Name of function. */ - int numArgs; /* Number of arguments for function. */ - Tcl_ValueType argTypes[MAX_MATH_ARGS]; - /* Acceptable types for each argument. */ - Tcl_MathProc *proc; /* Procedure that implements this function. */ - ClientData clientData; /* Additional argument to pass to the function - * when invoking it. */ -} BuiltinFunc; - -static BuiltinFunc funcTable[] = { -#ifndef TCL_NO_MATH - {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos}, - {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin}, - {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan}, - {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2}, - {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil}, - {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos}, - {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh}, - {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp}, - {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor}, - {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod}, - {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot}, - {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log}, - {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10}, - {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow}, - {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin}, - {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh}, - {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt}, - {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan}, - {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh}, -#endif - {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0}, - {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0}, - {"int", 1, {TCL_EITHER}, ExprIntFunc, 0}, - {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, - - {0}, -}; - -/* - *-------------------------------------------------------------- - * - * ExprParseString -- - * - * Given a string (such as one coming from command or variable - * substitution), make a Value based on the string. The value - * will be a floating-point or integer, if possible, or else it - * will just be a copy of the string. - * - * Results: - * TCL_OK is returned under normal circumstances, and TCL_ERROR - * is returned if a floating-point overflow or underflow occurred - * while reading in a number. The value at *valuePtr is modified - * to hold a number, if possible. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -static int -ExprParseString( - Tcl_Interp *interp, /* Where to store error message. */ - char *string, /* String to turn into value. */ - Value *valuePtr /* Where to store value information. - * Caller must have initialized pv field. */ -) -{ - char *term, *p, *start; - - if (*string != 0) { - if (ExprLooksLikeInt(string)) { - valuePtr->type = TYPE_INT; - errno = 0; - - /* - * 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. - */ - - for (p = string; isspace(UCHAR(*p)); p++) { - /* Empty loop body. */ - } - if (*p == '-') { - start = p+1; - valuePtr->intValue = -((int)strtoul(start, &term, 0)); - } else if (*p == '+') { - start = p+1; - valuePtr->intValue = strtoul(start, &term, 0); - } else { - start = p; - valuePtr->intValue = strtoul(start, &term, 0); - } - if (*term == 0) { - if (errno == ERANGE) { - /* - * This procedure is sometimes called with string in - * interp->result, so we have to clear the result before - * logging an error message. - */ - - Tcl_ResetResult(interp); - interp->result = "integer value too large to represent"; - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - interp->result, (char *) NULL); - return TCL_ERROR; - } else { - return TCL_OK; - } - } - } else { - errno = 0; -#ifdef __NetBSD__ - valuePtr->doubleValue = (double)strtof(string, &term); -#else - valuePtr->doubleValue = strtod(string, &term); -#endif - if ((term != string) && (*term == 0)) { - if (errno != 0) { - Tcl_ResetResult(interp); - TclExprFloatError(interp, valuePtr->doubleValue); - return TCL_ERROR; - } - valuePtr->type = TYPE_DOUBLE; - return TCL_OK; - } - } - } - - /* - * Not a valid number. Save a string value (but don't do anything - * if it's already the value). - */ - - valuePtr->type = TYPE_STRING; - if (string != valuePtr->pv.buffer) { - int length, shortfall; - - length = strlen(string); - valuePtr->pv.next = valuePtr->pv.buffer; - shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer); - if (shortfall > 0) { - (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); - } - strcpy(valuePtr->pv.buffer, string); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ExprLex -- - * - * Lexical analyzer for expression parser: parses a single value, - * operator, or other syntactic element from an expression string. - * - * Results: - * TCL_OK is returned unless an error occurred while doing lexical - * analysis or executing an embedded command. In that case a - * standard Tcl error is returned, using interp->result to hold - * an error message. In the event of a successful return, the token - * and field in infoPtr is updated to refer to the next symbol in - * the expression string, and the expr field is advanced past that - * token; if the token is a value, then the value is stored at - * valuePtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ExprLex( - Tcl_Interp *interp, /* Interpreter to use for error - * reporting. */ - ExprInfo *infoPtr, /* Describes the state of the parse. */ - Value *valuePtr /* Where to store value, if that is - * what's parsed from string. Caller - * must have initialized pv field - * correctly. */ -) -{ - char *p; - char *var, *term; - int result; - - p = infoPtr->expr; - while (isspace(UCHAR(*p))) { - p++; - } - if (*p == 0) { - infoPtr->token = END; - infoPtr->expr = p; - return TCL_OK; - } - - /* - * First try to parse the token as an integer or floating-point number. - * Don't want to check for a number if the first character is "+" - * or "-". If we do, we might treat a binary operator as unary by - * mistake, which will eventually cause a syntax error. - */ - - if ((*p != '+') && (*p != '-')) { - if (ExprLooksLikeInt(p)) { - errno = 0; - valuePtr->intValue = strtoul(p, &term, 0); - if (errno == ERANGE) { - interp->result = "integer value too large to represent"; - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - interp->result, (char *) NULL); - return TCL_ERROR; - } - infoPtr->token = VALUE; - infoPtr->expr = term; - valuePtr->type = TYPE_INT; - return TCL_OK; - } else { - errno = 0; -#ifdef __NetBSD__ - valuePtr->doubleValue = (double)strtof(p, &term); -#else - valuePtr->doubleValue = strtod(p, &term); -#endif - if (term != p) { - if (errno != 0) { - TclExprFloatError(interp, valuePtr->doubleValue); - return TCL_ERROR; - } - infoPtr->token = VALUE; - infoPtr->expr = term; - valuePtr->type = TYPE_DOUBLE; - return TCL_OK; - } - } - } - - infoPtr->expr = p+1; - switch (*p) { - case '$': - - /* - * Variable. Fetch its value, then see if it makes sense - * as an integer or floating-point number. - */ - - infoPtr->token = VALUE; - var = Tcl_ParseVar(interp, p, &infoPtr->expr); - if (var == NULL) { - return TCL_ERROR; - } - Tcl_ResetResult(interp); - if (((Interp *) interp)->noEval) { - valuePtr->type = TYPE_INT; - valuePtr->intValue = 0; - return TCL_OK; - } - return ExprParseString(interp, var, valuePtr); - - case '[': - infoPtr->token = VALUE; - ((Interp *) interp)->evalFlags = TCL_BRACKET_TERM; - result = Tcl_Eval(interp, p+1); - infoPtr->expr = ((Interp *) interp)->termPtr; - if (result != TCL_OK) { - return result; - } - infoPtr->expr++; - if (((Interp *) interp)->noEval) { - valuePtr->type = TYPE_INT; - valuePtr->intValue = 0; - Tcl_ResetResult(interp); - return TCL_OK; - } - result = ExprParseString(interp, interp->result, valuePtr); - if (result != TCL_OK) { - return result; - } - Tcl_ResetResult(interp); - return TCL_OK; - - case '"': - infoPtr->token = VALUE; - result = TclParseQuotes(interp, infoPtr->expr, '"', 0, - &infoPtr->expr, &valuePtr->pv); - if (result != TCL_OK) { - return result; - } - Tcl_ResetResult(interp); - return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); - - case '{': - infoPtr->token = VALUE; - result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr, - &valuePtr->pv); - if (result != TCL_OK) { - return result; - } - Tcl_ResetResult(interp); - return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); - - case '(': - infoPtr->token = OPEN_PAREN; - return TCL_OK; - - case ')': - infoPtr->token = CLOSE_PAREN; - return TCL_OK; - - case ',': - infoPtr->token = COMMA; - return TCL_OK; - - case '*': - infoPtr->token = MULT; - return TCL_OK; - - case '/': - infoPtr->token = DIVIDE; - return TCL_OK; - - case '%': - infoPtr->token = MOD; - return TCL_OK; - - case '+': - infoPtr->token = PLUS; - return TCL_OK; - - case '-': - infoPtr->token = MINUS; - return TCL_OK; - - case '?': - infoPtr->token = QUESTY; - return TCL_OK; - - case ':': - infoPtr->token = COLON; - return TCL_OK; - - case '<': - switch (p[1]) { - case '<': - infoPtr->expr = p+2; - infoPtr->token = LEFT_SHIFT; - break; - case '=': - infoPtr->expr = p+2; - infoPtr->token = LEQ; - break; - default: - infoPtr->token = LESS; - break; - } - return TCL_OK; - - case '>': - switch (p[1]) { - case '>': - infoPtr->expr = p+2; - infoPtr->token = RIGHT_SHIFT; - break; - case '=': - infoPtr->expr = p+2; - infoPtr->token = GEQ; - break; - default: - infoPtr->token = GREATER; - break; - } - return TCL_OK; - - case '=': - if (p[1] == '=') { - infoPtr->expr = p+2; - infoPtr->token = EQUAL; - } else { - infoPtr->token = UNKNOWN; - } - return TCL_OK; - - case '!': - if (p[1] == '=') { - infoPtr->expr = p+2; - infoPtr->token = NEQ; - } else { - infoPtr->token = NOT; - } - return TCL_OK; - - case '&': - if (p[1] == '&') { - infoPtr->expr = p+2; - infoPtr->token = AND; - } else { - infoPtr->token = BIT_AND; - } - return TCL_OK; - - case '^': - infoPtr->token = BIT_XOR; - return TCL_OK; - - case '|': - if (p[1] == '|') { - infoPtr->expr = p+2; - infoPtr->token = OR; - } else { - infoPtr->token = BIT_OR; - } - return TCL_OK; - - case '~': - infoPtr->token = BIT_NOT; - return TCL_OK; - - default: - if (isalpha(UCHAR(*p))) { - infoPtr->expr = p; - return ExprMathFunc(interp, infoPtr, valuePtr); - } - infoPtr->expr = p+1; - infoPtr->token = UNKNOWN; - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * ExprGetValue -- - * - * Parse a "value" from the remainder of the expression in infoPtr. - * - * Results: - * Normally TCL_OK is returned. The value of the expression is - * returned in *valuePtr. If an error occurred, then interp->result - * contains an error message and TCL_ERROR is returned. - * InfoPtr->token will be left pointing to the token AFTER the - * expression, and infoPtr->expr will point to the character just - * after the terminating token. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ExprGetValue( - Tcl_Interp *interp, /* Interpreter to use for error - * reporting. */ - ExprInfo *infoPtr, /* Describes the state of the parse - * just before the value (i.e. ExprLex - * will be called to get first token - * of value). */ - int prec, /* Treat any un-parenthesized operator - * with precedence <= this as the end - * of the expression. */ - Value *valuePtr /* Where to store the value of the - * expression. Caller must have - * initialized pv field. */ -) -{ - Interp *iPtr = (Interp *) interp; - Value value2; /* Second operand for current - * operator. */ - int operator; /* Current operator (either unary - * or binary). */ - int badType; /* Type of offending argument; used - * for error messages. */ - int gotOp; /* Non-zero means already lexed the - * operator (while picking up value - * for unary operator). Don't lex - * again. */ - int result; - - /* - * There are two phases to this procedure. First, pick off an initial - * value. Then, parse (binary operator, value) pairs until done. - */ - - gotOp = 0; - value2.pv.buffer = value2.pv.next = value2.staticSpace; - value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1; - value2.pv.expandProc = TclExpandParseValue; - value2.pv.clientData = (ClientData) NULL; - result = ExprLex(interp, infoPtr, valuePtr); - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token == OPEN_PAREN) { - - /* - * Parenthesized sub-expression. - */ - - result = ExprGetValue(interp, infoPtr, -1, valuePtr); - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token != CLOSE_PAREN) { - Tcl_AppendResult(interp, "unmatched parentheses in expression \"", - infoPtr->originalExpr, "\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - } else { - if (infoPtr->token == MINUS) { - infoPtr->token = UNARY_MINUS; - } - if (infoPtr->token == PLUS) { - infoPtr->token = UNARY_PLUS; - } - if (infoPtr->token >= UNARY_MINUS) { - - /* - * Process unary operators. - */ - - operator = infoPtr->token; - result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token], - valuePtr); - if (result != TCL_OK) { - goto done; - } - if (!iPtr->noEval) { - switch (operator) { - case UNARY_MINUS: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = -valuePtr->intValue; - } else if (valuePtr->type == TYPE_DOUBLE){ - valuePtr->doubleValue = -valuePtr->doubleValue; - } else { - badType = valuePtr->type; - goto illegalType; - } - break; - case UNARY_PLUS: - if ((valuePtr->type != TYPE_INT) - && (valuePtr->type != TYPE_DOUBLE)) { - badType = valuePtr->type; - goto illegalType; - } - break; - case NOT: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = !valuePtr->intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - /* - * Theoretically, should be able to use - * "!valuePtr->intValue", but apparently some - * compilers can't handle it. - */ - if (valuePtr->doubleValue == 0.0) { - valuePtr->intValue = 1; - } else { - valuePtr->intValue = 0; - } - valuePtr->type = TYPE_INT; - } else { - badType = valuePtr->type; - goto illegalType; - } - break; - case BIT_NOT: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = ~valuePtr->intValue; - } else { - badType = valuePtr->type; - goto illegalType; - } - break; - } - } - gotOp = 1; - } else if (infoPtr->token != VALUE) { - goto syntaxError; - } - } - - /* - * Got the first operand. Now fetch (operator, operand) pairs. - */ - - if (!gotOp) { - result = ExprLex(interp, infoPtr, &value2); - if (result != TCL_OK) { - goto done; - } - } - while (1) { - operator = infoPtr->token; - value2.pv.next = value2.pv.buffer; - if ((operator < MULT) || (operator >= UNARY_MINUS)) { - if ((operator == END) || (operator == CLOSE_PAREN) - || (operator == COMMA)) { - result = TCL_OK; - goto done; - } else { - goto syntaxError; - } - } - if (precTable[operator] <= prec) { - result = TCL_OK; - goto done; - } - - /* - * If we're doing an AND or OR and the first operand already - * determines the result, don't execute anything in the - * second operand: just parse. Same style for ?: pairs. - */ - - if ((operator == AND) || (operator == OR) || (operator == QUESTY)) { - if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = valuePtr->doubleValue != 0; - valuePtr->type = TYPE_INT; - } else if (valuePtr->type == TYPE_STRING) { - if (!iPtr->noEval) { - badType = TYPE_STRING; - goto illegalType; - } - - /* - * Must set valuePtr->intValue to avoid referencing - * uninitialized memory in the "if" below; the atual - * value doesn't matter, since it will be ignored. - */ - - valuePtr->intValue = 0; - } - if (((operator == AND) && !valuePtr->intValue) - || ((operator == OR) && valuePtr->intValue)) { - iPtr->noEval++; - result = ExprGetValue(interp, infoPtr, precTable[operator], - &value2); - iPtr->noEval--; - if (operator == OR) { - valuePtr->intValue = 1; - } - continue; - } else if (operator == QUESTY) { - /* - * Special note: ?: operators must associate right to - * left. To make this happen, use a precedence one lower - * than QUESTY when calling ExprGetValue recursively. - */ - - if (valuePtr->intValue != 0) { - valuePtr->pv.next = valuePtr->pv.buffer; - result = ExprGetValue(interp, infoPtr, - precTable[QUESTY] - 1, valuePtr); - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token != COLON) { - goto syntaxError; - } - value2.pv.next = value2.pv.buffer; - iPtr->noEval++; - result = ExprGetValue(interp, infoPtr, - precTable[QUESTY] - 1, &value2); - iPtr->noEval--; - } else { - iPtr->noEval++; - result = ExprGetValue(interp, infoPtr, - precTable[QUESTY] - 1, &value2); - iPtr->noEval--; - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token != COLON) { - goto syntaxError; - } - valuePtr->pv.next = valuePtr->pv.buffer; - result = ExprGetValue(interp, infoPtr, - precTable[QUESTY] - 1, valuePtr); - } - continue; - } else { - result = ExprGetValue(interp, infoPtr, precTable[operator], - &value2); - } - } else { - result = ExprGetValue(interp, infoPtr, precTable[operator], - &value2); - } - if (result != TCL_OK) { - goto done; - } - if ((infoPtr->token < MULT) && (infoPtr->token != VALUE) - && (infoPtr->token != END) && (infoPtr->token != COMMA) - && (infoPtr->token != CLOSE_PAREN)) { - goto syntaxError; - } - - if (iPtr->noEval) { - continue; - } - - /* - * At this point we've got two values and an operator. Check - * to make sure that the particular data types are appropriate - * for the particular operator, and perform type conversion - * if necessary. - */ - - switch (operator) { - - /* - * For the operators below, no strings are allowed and - * ints get converted to floats if necessary. - */ - - case MULT: case DIVIDE: case PLUS: case MINUS: - if ((valuePtr->type == TYPE_STRING) - || (value2.type == TYPE_STRING)) { - badType = TYPE_STRING; - goto illegalType; - } - if (valuePtr->type == TYPE_DOUBLE) { - if (value2.type == TYPE_INT) { - value2.doubleValue = value2.intValue; - value2.type = TYPE_DOUBLE; - } - } else if (value2.type == TYPE_DOUBLE) { - if (valuePtr->type == TYPE_INT) { - valuePtr->doubleValue = valuePtr->intValue; - valuePtr->type = TYPE_DOUBLE; - } - } - break; - - /* - * For the operators below, only integers are allowed. - */ - - case MOD: case LEFT_SHIFT: case RIGHT_SHIFT: - case BIT_AND: case BIT_XOR: case BIT_OR: - if (valuePtr->type != TYPE_INT) { - badType = valuePtr->type; - goto illegalType; - } else if (value2.type != TYPE_INT) { - badType = value2.type; - goto illegalType; - } - break; - - /* - * For the operators below, any type is allowed but the - * two operands must have the same type. Convert integers - * to floats and either to strings, if necessary. - */ - - case LESS: case GREATER: case LEQ: case GEQ: - case EQUAL: case NEQ: - if (valuePtr->type == TYPE_STRING) { - if (value2.type != TYPE_STRING) { - ExprMakeString(interp, &value2); - } - } else if (value2.type == TYPE_STRING) { - if (valuePtr->type != TYPE_STRING) { - ExprMakeString(interp, valuePtr); - } - } else if (valuePtr->type == TYPE_DOUBLE) { - if (value2.type == TYPE_INT) { - value2.doubleValue = value2.intValue; - value2.type = TYPE_DOUBLE; - } - } else if (value2.type == TYPE_DOUBLE) { - if (valuePtr->type == TYPE_INT) { - valuePtr->doubleValue = valuePtr->intValue; - valuePtr->type = TYPE_DOUBLE; - } - } - break; - - /* - * For the operators below, no strings are allowed, but - * no int->double conversions are performed. - */ - - case AND: case OR: - if (valuePtr->type == TYPE_STRING) { - badType = valuePtr->type; - goto illegalType; - } - if (value2.type == TYPE_STRING) { - badType = value2.type; - goto illegalType; - } - break; - - /* - * For the operators below, type and conversions are - * irrelevant: they're handled elsewhere. - */ - - case QUESTY: case COLON: - break; - - /* - * Any other operator is an error. - */ - - default: - interp->result = "unknown operator in expression"; - result = TCL_ERROR; - goto done; - } - - /* - * Carry out the function of the specified operator. - */ - - switch (operator) { - case MULT: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = valuePtr->intValue * value2.intValue; - } else { - valuePtr->doubleValue *= value2.doubleValue; - } - break; - case DIVIDE: - case MOD: - if (valuePtr->type == TYPE_INT) { - long divisor, quot, rem; - int negative; - - if (value2.intValue == 0) { - divideByZero: - interp->result = "divide by zero"; - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", - interp->result, (char *) NULL); - result = TCL_ERROR; - goto done; - } - - /* - * The code below is tricky because C doesn't guarantee - * much about the properties of the quotient or - * remainder, but Tcl does: the remainder always has - * the same sign as the divisor and a smaller absolute - * value. - */ - - divisor = value2.intValue; - negative = 0; - if (divisor < 0) { - divisor = -divisor; - valuePtr->intValue = -valuePtr->intValue; - negative = 1; - } - quot = valuePtr->intValue / divisor; - rem = valuePtr->intValue % divisor; - if (rem < 0) { - rem += divisor; - quot -= 1; - } - if (negative) { - rem = -rem; - } - valuePtr->intValue = (operator == DIVIDE) ? quot : rem; - } else { - if (value2.doubleValue == 0.0) { - goto divideByZero; - } - valuePtr->doubleValue /= value2.doubleValue; - } - break; - case PLUS: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = valuePtr->intValue + value2.intValue; - } else { - valuePtr->doubleValue += value2.doubleValue; - } - break; - case MINUS: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = valuePtr->intValue - value2.intValue; - } else { - valuePtr->doubleValue -= value2.doubleValue; - } - break; - case LEFT_SHIFT: - valuePtr->intValue <<= value2.intValue; - break; - case RIGHT_SHIFT: - /* - * The following code is a bit tricky: it ensures that - * right shifts propagate the sign bit even on machines - * where ">>" won't do it by default. - */ - - if (valuePtr->intValue < 0) { - valuePtr->intValue = - ~((~valuePtr->intValue) >> value2.intValue); - } else { - valuePtr->intValue >>= value2.intValue; - } - break; - case LESS: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue < value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue < value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0; - } - valuePtr->type = TYPE_INT; - break; - case GREATER: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue > value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue > value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0; - } - valuePtr->type = TYPE_INT; - break; - case LEQ: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue <= value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue <= value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0; - } - valuePtr->type = TYPE_INT; - break; - case GEQ: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue >= value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue >= value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0; - } - valuePtr->type = TYPE_INT; - break; - case EQUAL: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue == value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue == value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0; - } - valuePtr->type = TYPE_INT; - break; - case NEQ: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue != value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue != value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0; - } - valuePtr->type = TYPE_INT; - break; - case BIT_AND: - valuePtr->intValue &= value2.intValue; - break; - case BIT_XOR: - valuePtr->intValue ^= value2.intValue; - break; - case BIT_OR: - valuePtr->intValue |= value2.intValue; - break; - - /* - * For AND and OR, we know that the first value has already - * been converted to an integer. Thus we need only consider - * the possibility of int vs. double for the second value. - */ - - case AND: - if (value2.type == TYPE_DOUBLE) { - value2.intValue = value2.doubleValue != 0; - value2.type = TYPE_INT; - } - valuePtr->intValue = valuePtr->intValue && value2.intValue; - break; - case OR: - if (value2.type == TYPE_DOUBLE) { - value2.intValue = value2.doubleValue != 0; - value2.type = TYPE_INT; - } - valuePtr->intValue = valuePtr->intValue || value2.intValue; - break; - - case COLON: - interp->result = "can't have : operator without ? first"; - result = TCL_ERROR; - goto done; - } - } - - done: - if (value2.pv.buffer != value2.staticSpace) { - ckfree(value2.pv.buffer); - } - return result; - - syntaxError: - Tcl_AppendResult(interp, "syntax error in expression \"", - infoPtr->originalExpr, "\"", (char *) NULL); - result = TCL_ERROR; - goto done; - - illegalType: - Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ? - "floating-point value" : "non-numeric string", - " as operand of \"", operatorStrings[operator], "\"", - (char *) NULL); - result = TCL_ERROR; - goto done; -} - -/* - *-------------------------------------------------------------- - * - * ExprMakeString -- - * - * Convert a value from int or double representation to - * a string. - * - * Results: - * The information at *valuePtr gets converted to string - * format, if it wasn't that way already. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -static void -ExprMakeString( - Tcl_Interp *interp, /* Interpreter to use for precision - * information. */ - Value *valuePtr /* Value to be converted. */ -) -{ - int shortfall; - - shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer); - if (shortfall > 0) { - (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); - } - if (valuePtr->type == TYPE_INT) { - sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue); - } else if (valuePtr->type == TYPE_DOUBLE) { - Tcl_PrintDouble(interp, valuePtr->doubleValue, valuePtr->pv.buffer); - } - valuePtr->type = TYPE_STRING; -} - -/* - *-------------------------------------------------------------- - * - * ExprTopLevel -- - * - * This procedure provides top-level functionality shared by - * procedures like Tcl_ExprInt, Tcl_ExprDouble, etc. - * - * Results: - * The result is a standard Tcl return value. If an error - * occurs then an error message is left in interp->result. - * The value of the expression is returned in *valuePtr, in - * whatever form it ends up in (could be string or integer - * or double). Caller may need to convert result. Caller - * is also responsible for freeing string memory in *valuePtr, - * if any was allocated. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -static int -ExprTopLevel( - Tcl_Interp *interp, /* Context in which to evaluate the - * expression. */ - char *string, /* Expression to evaluate. */ - Value *valuePtr /* Where to store result. Should - * not be initialized by caller. */ -) -{ - ExprInfo info; - int result; - - /* - * Create the math functions the first time an expression is - * evaluated. - */ - - if (!(((Interp *) interp)->flags & EXPR_INITIALIZED)) { - BuiltinFunc *funcPtr; - - ((Interp *) interp)->flags |= EXPR_INITIALIZED; - for (funcPtr = funcTable; funcPtr->name != NULL; - funcPtr++) { - Tcl_CreateMathFunc(interp, funcPtr->name, funcPtr->numArgs, - funcPtr->argTypes, funcPtr->proc, funcPtr->clientData); - } - } - - info.originalExpr = string; - info.expr = string; - valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace; - valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1; - valuePtr->pv.expandProc = TclExpandParseValue; - valuePtr->pv.clientData = (ClientData) NULL; - - result = ExprGetValue(interp, &info, -1, valuePtr); - if (result != TCL_OK) { - return result; - } - if (info.token != END) { - Tcl_AppendResult(interp, "syntax error in expression \"", - string, "\"", (char *) NULL); - return TCL_ERROR; - } - if ((valuePtr->type == TYPE_DOUBLE) && (IS_NAN(valuePtr->doubleValue) - || IS_INF(valuePtr->doubleValue))) { - /* - * IEEE floating-point error. - */ - - TclExprFloatError(interp, valuePtr->doubleValue); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- - * - * Procedures to evaluate an expression and return its value - * in a particular form. - * - * Results: - * Each of the procedures below returns a standard Tcl result. - * If an error occurs then an error message is left in - * interp->result. Otherwise the value of the expression, - * in the appropriate form, is stored at *resultPtr. If - * the expression had a result that was incompatible with the - * desired form then an error is returned. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -int -Tcl_ExprLong( - Tcl_Interp *interp, /* Context in which to evaluate the - * expression. */ - char *string, /* Expression to evaluate. */ - long *ptr /* Where to store result. */ -) -{ - Value value; - int result; - - result = ExprTopLevel(interp, string, &value); - if (result == TCL_OK) { - if (value.type == TYPE_INT) { - *ptr = value.intValue; - } else if (value.type == TYPE_DOUBLE) { - *ptr = (long) value.doubleValue; - } else { - interp->result = "expression didn't have numeric value"; - result = TCL_ERROR; - } - } - if (value.pv.buffer != value.staticSpace) { - ckfree(value.pv.buffer); - } - return result; -} - -int -Tcl_ExprDouble( - Tcl_Interp *interp, /* Context in which to evaluate the - * expression. */ - char *string, /* Expression to evaluate. */ - double *ptr /* Where to store result. */ -) -{ - Value value; - int result; - - result = ExprTopLevel(interp, string, &value); - if (result == TCL_OK) { - if (value.type == TYPE_INT) { - *ptr = value.intValue; - } else if (value.type == TYPE_DOUBLE) { - *ptr = value.doubleValue; - } else { - interp->result = "expression didn't have numeric value"; - result = TCL_ERROR; - } - } - if (value.pv.buffer != value.staticSpace) { - ckfree(value.pv.buffer); - } - return result; -} - -int -Tcl_ExprBoolean( - Tcl_Interp *interp, /* Context in which to evaluate the - * expression. */ - char *string, /* Expression to evaluate. */ - int *ptr /* Where to store 0/1 result. */ -) -{ - Value value; - int result; - - result = ExprTopLevel(interp, string, &value); - if (result == TCL_OK) { - if (value.type == TYPE_INT) { - *ptr = value.intValue != 0; - } else if (value.type == TYPE_DOUBLE) { - *ptr = value.doubleValue != 0.0; - } else { - result = Tcl_GetBoolean(interp, value.pv.buffer, ptr); - } - } - if (value.pv.buffer != value.staticSpace) { - ckfree(value.pv.buffer); - } - return result; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_ExprString -- - * - * Evaluate an expression and return its value in string form. - * - * Results: - * A standard Tcl result. If the result is TCL_OK, then the - * interpreter's result is set to the string value of the - * expression. If the result is TCL_OK, then interp->result - * contains an error message. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -int -Tcl_ExprString( - Tcl_Interp *interp, /* Context in which to evaluate the - * expression. */ - char *string /* Expression to evaluate. */ -) -{ - Value value; - int result; - - result = ExprTopLevel(interp, string, &value); - if (result == TCL_OK) { - if (value.type == TYPE_INT) { - sprintf(interp->result, "%ld", value.intValue); - } else if (value.type == TYPE_DOUBLE) { - Tcl_PrintDouble(interp, value.doubleValue, interp->result); - } else { - if (value.pv.buffer != value.staticSpace) { - interp->result = value.pv.buffer; - interp->freeProc = TCL_DYNAMIC; - value.pv.buffer = value.staticSpace; - } else { - Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE); - } - } - } - if (value.pv.buffer != value.staticSpace) { - ckfree(value.pv.buffer); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateMathFunc -- - * - * Creates a new math function for expressions in a given - * interpreter. - * - * Results: - * None. - * - * Side effects: - * The function defined by "name" is created; if such a function - * already existed then its definition is overriden. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CreateMathFunc( - Tcl_Interp *interp, /* Interpreter in which function is - * to be available. */ - char *name, /* Name of function (e.g. "sin"). */ - int numArgs, /* Nnumber of arguments required by - * function. */ - Tcl_ValueType *argTypes, /* Array of types acceptable for - * each argument. */ - Tcl_MathProc *proc, /* Procedure that implements the - * math function. */ - ClientData clientData /* Additional value to pass to the - * function. */ -) -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int new, i; - - hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); - if (new) { - Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - if (numArgs > MAX_MATH_ARGS) { - numArgs = MAX_MATH_ARGS; - } - mathFuncPtr->numArgs = numArgs; - for (i = 0; i < numArgs; i++) { - mathFuncPtr->argTypes[i] = argTypes[i]; - } - mathFuncPtr->proc = proc; - mathFuncPtr->clientData = clientData; -} - -/* - *---------------------------------------------------------------------- - * - * ExprMathFunc -- - * - * This procedure is invoked to parse a math function from an - * expression string, carry out the function, and return the - * value computed. - * - * Results: - * TCL_OK is returned if all went well and the function's value - * was computed successfully. If an error occurred, TCL_ERROR - * is returned and an error message is left in interp->result. - * After a successful return infoPtr has been updated to refer - * to the character just after the function call, the token is - * set to VALUE, and the value is stored in valuePtr. - * - * Side effects: - * Embedded commands could have arbitrary side-effects. - * - *---------------------------------------------------------------------- - */ - -static int -ExprMathFunc( - Tcl_Interp *interp, /* Interpreter to use for error - * reporting. */ - ExprInfo *infoPtr, /* Describes the state of the parse. - * infoPtr->expr must point to the - * first character of the function's - * name. */ - Value *valuePtr /* Where to store value, if that is - * what's parsed from string. Caller - * must have initialized pv field - * correctly. */ -) -{ - Interp *iPtr = (Interp *) interp; - MathFunc *mathFuncPtr; /* Info about math function. */ - Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ - Tcl_Value funcResult; /* Result of function call. */ - Tcl_HashEntry *hPtr; - char *p, *funcName, savedChar; - int i, result; - - /* - * Find the end of the math function's name and lookup the MathFunc - * record for the function. - */ - - p = funcName = infoPtr->expr; - while (isalnum(UCHAR(*p)) || (*p == '_')) { - p++; - } - infoPtr->expr = p; - result = ExprLex(interp, infoPtr, valuePtr); - if (result != TCL_OK) { - return TCL_ERROR; - } - if (infoPtr->token != OPEN_PAREN) { - goto syntaxError; - } - savedChar = *p; - *p = 0; - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown math function \"", funcName, - "\"", (char *) NULL); - *p = savedChar; - return TCL_ERROR; - } - *p = savedChar; - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - - /* - * Scan off the arguments for the function, if there are any. - */ - - if (mathFuncPtr->numArgs == 0) { - result = ExprLex(interp, infoPtr, valuePtr); - if ((result != TCL_OK) || (infoPtr->token != CLOSE_PAREN)) { - goto syntaxError; - } - } else { - for (i = 0; ; i++) { - valuePtr->pv.next = valuePtr->pv.buffer; - result = ExprGetValue(interp, infoPtr, -1, valuePtr); - if (result != TCL_OK) { - return result; - } - if (valuePtr->type == TYPE_STRING) { - interp->result = - "argument to math function didn't have numeric value"; - return TCL_ERROR; - } - - /* - * Copy the value to the argument record, converting it if - * necessary. - */ - - if (valuePtr->type == TYPE_INT) { - if (mathFuncPtr->argTypes[i] == TCL_DOUBLE) { - args[i].type = TCL_DOUBLE; - args[i].doubleValue = valuePtr->intValue; - } else { - args[i].type = TCL_INT; - args[i].intValue = valuePtr->intValue; - } - } else { - if (mathFuncPtr->argTypes[i] == TCL_INT) { - args[i].type = TCL_INT; - args[i].intValue = (long) valuePtr->doubleValue; - } else { - args[i].type = TCL_DOUBLE; - args[i].doubleValue = valuePtr->doubleValue; - } - } - - /* - * Check for a comma separator between arguments or a close-paren - * to end the argument list. - */ - - if (i == (mathFuncPtr->numArgs-1)) { - if (infoPtr->token == CLOSE_PAREN) { - break; - } - if (infoPtr->token == COMMA) { - interp->result = "too many arguments for math function"; - return TCL_ERROR; - } else { - goto syntaxError; - } - } - if (infoPtr->token != COMMA) { - if (infoPtr->token == CLOSE_PAREN) { - interp->result = "too few arguments for math function"; - return TCL_ERROR; - } else { - goto syntaxError; - } - } - } - } - if (iPtr->noEval) { - valuePtr->type = TYPE_INT; - valuePtr->intValue = 0; - infoPtr->token = VALUE; - return TCL_OK; - } - - /* - * Invoke the function and copy its result back into valuePtr. - */ - - tcl_MathInProgress++; - result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, - &funcResult); - tcl_MathInProgress--; - if (result != TCL_OK) { - return result; - } - if (funcResult.type == TCL_INT) { - valuePtr->type = TYPE_INT; - valuePtr->intValue = funcResult.intValue; - } else { - valuePtr->type = TYPE_DOUBLE; - valuePtr->doubleValue = funcResult.doubleValue; - } - infoPtr->token = VALUE; - return TCL_OK; - - syntaxError: - Tcl_AppendResult(interp, "syntax error in expression \"", - infoPtr->originalExpr, "\"", (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclExprFloatError -- - * - * This procedure is called when an error occurs during a - * floating-point operation. It reads errno and sets - * interp->result accordingly. - * - * Results: - * Interp->result is set to hold an error message. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclExprFloatError( - Tcl_Interp *interp, /* Where to store error message. */ - double value /* Value returned after error; used to - * distinguish underflows from overflows. */ -) -{ - char buf[20]; - - if ((errno == EDOM) || (value != value)) { - interp->result = "domain error: argument not in valid range"; - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", interp->result, - (char *) NULL); - } else if ((errno == ERANGE) || IS_INF(value)) { - if (value == 0.0) { - interp->result = "floating-point value too small to represent"; - Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", interp->result, - (char *) NULL); - } else { - interp->result = "floating-point value too large to represent"; - Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", interp->result, - (char *) NULL); - } - } else { - sprintf(buf, "%d", errno); - Tcl_AppendResult(interp, "unknown floating-point error, ", - "errno = ", buf, (char *) NULL); - Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", interp->result, - (char *) NULL); - } -} - -/* - *---------------------------------------------------------------------- - * - * Math Functions -- - * - * This page contains the procedures that implement all of the - * built-in math functions for expressions. - * - * Results: - * Each procedure returns TCL_OK if it succeeds and places result - * information at *resultPtr. If it fails it returns TCL_ERROR - * and leaves an error message in interp->result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ExprUnaryFunc( - ClientData clientData, /* Contains address of procedure that - * takes one double argument and - * returns a double result. */ - Tcl_Interp *interp, - Tcl_Value *args, - Tcl_Value *resultPtr -) -{ - double (*func) _ANSI_ARGS_((double)) = (double (*)_ANSI_ARGS_((double))) clientData; - - errno = 0; - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = (*func)(args[0].doubleValue); - if (errno != 0) { - TclExprFloatError(interp, resultPtr->doubleValue); - return TCL_ERROR; - } - return TCL_OK; -} - -static int -ExprBinaryFunc( - ClientData clientData, /* Contains address of procedure that - * takes two double arguments and - * returns a double result. */ - Tcl_Interp *interp, - Tcl_Value *args, - Tcl_Value *resultPtr -) -{ - double (*func) _ANSI_ARGS_((double, double)) - = (double (*)_ANSI_ARGS_((double, double))) clientData; - - errno = 0; - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = (*func)(args[0].doubleValue, args[1].doubleValue); - if (errno != 0) { - TclExprFloatError(interp, resultPtr->doubleValue); - return TCL_ERROR; - } - return TCL_OK; -} - - /* ARGSUSED */ -static int -ExprAbsFunc( - ClientData clientData, - Tcl_Interp *interp, - Tcl_Value *args, - Tcl_Value *resultPtr -) -{ - resultPtr->type = TCL_DOUBLE; - if (args[0].type == TCL_DOUBLE) { - resultPtr->type = TCL_DOUBLE; - if (args[0].doubleValue < 0) { - resultPtr->doubleValue = -args[0].doubleValue; - } else { - resultPtr->doubleValue = args[0].doubleValue; - } - } else { - resultPtr->type = TCL_INT; - if (args[0].intValue < 0) { - resultPtr->intValue = -args[0].intValue; - if (resultPtr->intValue < 0) { - interp->result = "integer value too large to represent"; - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, - (char *) NULL); - return TCL_ERROR; - } - } else { - resultPtr->intValue = args[0].intValue; - } - } - return TCL_OK; -} - - /* ARGSUSED */ -static int -ExprDoubleFunc( - ClientData clientData, - Tcl_Interp *interp, - Tcl_Value *args, - Tcl_Value *resultPtr -) -{ - resultPtr->type = TCL_DOUBLE; - if (args[0].type == TCL_DOUBLE) { - resultPtr->doubleValue = args[0].doubleValue; - } else { - resultPtr->doubleValue = args[0].intValue; - } - return TCL_OK; -} - - /* ARGSUSED */ -static int -ExprIntFunc( - ClientData clientData, - Tcl_Interp *interp, - Tcl_Value *args, - Tcl_Value *resultPtr -) -{ - resultPtr->type = TCL_INT; - if (args[0].type == TCL_INT) { - resultPtr->intValue = args[0].intValue; - } else { - if (args[0].doubleValue < 0) { - if (args[0].doubleValue < (double) (long) LONG_MIN) { - tooLarge: - interp->result = "integer value too large to represent"; - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - interp->result, (char *) NULL); - return TCL_ERROR; - } - } else { - if (args[0].doubleValue > (double) LONG_MAX) { - goto tooLarge; - } - } - resultPtr->intValue = (long) args[0].doubleValue; - } - return TCL_OK; -} - - /* ARGSUSED */ -static int -ExprRoundFunc( - ClientData clientData, - Tcl_Interp *interp, - Tcl_Value *args, - Tcl_Value *resultPtr -) -{ - resultPtr->type = TCL_INT; - if (args[0].type == TCL_INT) { - resultPtr->intValue = args[0].intValue; - } else { - if (args[0].doubleValue < 0) { - if (args[0].doubleValue <= (((double) (long) LONG_MIN) - 0.5)) { - tooLarge: - interp->result = "integer value too large to represent"; - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - interp->result, (char *) NULL); - return TCL_ERROR; - } - resultPtr->intValue = (long) (args[0].doubleValue - 0.5); - } else { - if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) { - goto tooLarge; - } - resultPtr->intValue = (long) (args[0].doubleValue + 0.5); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ExprLooksLikeInt -- - * - * This procedure decides whether the leading characters of a - * string look like an integer or something else (such as a - * floating-point number or string). - * - * Results: - * The return value is 1 if the leading characters of p look - * like a valid Tcl integer. If they look like a floating-point - * number (e.g. "e01" or "2.4"), or if they don't look like a - * number at all, then 0 is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ExprLooksLikeInt( - char *p /* Pointer to string. */ -) -{ - while (isspace(UCHAR(*p))) { - p++; - } - if ((*p == '+') || (*p == '-')) { - p++; - } - if (!isdigit(UCHAR(*p))) { - return 0; - } - p++; - while (isdigit(UCHAR(*p))) { - p++; - } - if ((*p != '.') && (*p != 'e') && (*p != 'E')) { - return 1; - } - return 0; -} diff --git a/cde/programs/dtdocbook/tcl/tclFHandle.c b/cde/programs/dtdocbook/tcl/tclFHandle.c deleted file mode 100644 index f6794bee..00000000 --- a/cde/programs/dtdocbook/tcl/tclFHandle.c +++ /dev/null @@ -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); -} diff --git a/cde/programs/dtdocbook/tcl/tclFileName.c b/cde/programs/dtdocbook/tcl/tclFileName.c deleted file mode 100644 index f9ffbbdf..00000000 --- a/cde/programs/dtdocbook/tcl/tclFileName.c +++ /dev/null @@ -1,1628 +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: tclFileName.c /main/2 1996/08/08 14:43:59 cde-hp $ */ -/* - * tclFileName.c -- - * - * This file contains routines for converting file names betwen - * native and network form. - * - * 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: @(#) tclFileName.c 1.23 96/04/19 12:34:28 - */ - -#include "tclInt.h" -#include "tclPort.h" -#include "tclRegexp.h" - -/* - * This variable indicates whether the cleanup procedure has been - * registered for this file yet. - */ - -static int initialized = 0; - -/* - * The following regular expression matches the root portion of a Windows - * absolute or volume relative path. It will match both UNC and drive relative - * paths. - */ - -#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\][/\\]+([^/\\]+)[/\\]+([^/\\]+)|([/\\]))([/\\])*" - -/* - * The following regular expression matches the root portion of a Macintosh - * absolute path. It will match degenerate Unix-style paths, tilde paths, - * Unix-style paths, and Mac paths. - */ - -#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$" - -/* - * The following variables are used to hold precompiled regular expressions - * for use in filename matching. - */ - -static regexp *winRootPatternPtr = NULL; -static regexp *macRootPatternPtr = NULL; - -/* - * The following variable is set in the TclPlatformInit call to one - * of: TCL_PLATFORM_UNIX, TCL_PLATFORM_MAC, or TCL_PLATFORM_WINDOWS. - */ - -TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; - -/* - * Prototypes for local procedures defined in this file: - */ - -static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, - char *user, Tcl_DString *resultPtr)); -static char * ExtractWinRoot _ANSI_ARGS_((char *path, - Tcl_DString *resultPtr, int offset)); -static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); -static int SkipToChar _ANSI_ARGS_((char **stringPtr, - char *match)); -static char * SplitMacPath _ANSI_ARGS_((char *path, - Tcl_DString *bufPtr)); -static char * SplitWinPath _ANSI_ARGS_((char *path, - Tcl_DString *bufPtr)); -static char * SplitUnixPath _ANSI_ARGS_((char *path, - Tcl_DString *bufPtr)); - -/* - *---------------------------------------------------------------------- - * - * FileNameCleanup -- - * - * This procedure is a Tcl_ExitProc used to clean up the static - * data structures used in this file. - * - * Results: - * None. - * - * Side effects: - * Deallocates storage used by the procedures in this file. - * - *---------------------------------------------------------------------- - */ - -static void -FileNameCleanup( - ClientData clientData /* Not used. */ -) -{ - if (winRootPatternPtr != NULL) { - ckfree((char *)winRootPatternPtr); - } - if (macRootPatternPtr != NULL) { - ckfree((char *)macRootPatternPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * ExtractWinRoot -- - * - * Matches the root portion of a Windows path and appends it - * to the specified Tcl_DString. - * - * Results: - * Returns the position in the path immediately after the root - * including any trailing slashes. - * Appends a cleaned up version of the root to the Tcl_DString - * at the specified offest. - * - * Side effects: - * Modifies the specified Tcl_DString. - * - *---------------------------------------------------------------------- - */ - -static char * -ExtractWinRoot( - char *path, /* Path to parse. */ - Tcl_DString *resultPtr, /* Buffer to hold result. */ - int offset /* Offset in buffer where result should be - * stored. */ -) -{ - int length; - - /* - * Initialize the path name parser for Windows path names. - */ - - if (winRootPatternPtr == NULL) { - winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } - - /* - * Match the root portion of a Windows path name. - */ - - if (!TclRegExec(winRootPatternPtr, path, path)) { - return path; - } - - Tcl_DStringSetLength(resultPtr, offset); - - if (winRootPatternPtr->startp[2] != NULL) { - Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[2], 2); - if (winRootPatternPtr->startp[6] != NULL) { - Tcl_DStringAppend(resultPtr, "/", 1); - } - } else if (winRootPatternPtr->startp[4] != NULL) { - Tcl_DStringAppend(resultPtr, "//", 2); - length = winRootPatternPtr->endp[3] - - winRootPatternPtr->startp[3]; - Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[3], length); - Tcl_DStringAppend(resultPtr, "/", 1); - length = winRootPatternPtr->endp[4] - - winRootPatternPtr->startp[4]; - Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[4], length); - } else { - Tcl_DStringAppend(resultPtr, "/", 1); - } - return winRootPatternPtr->endp[0]; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetPathType -- - * - * Determines whether a given path is relative to the current - * directory, relative to the current volume, or absolute. - * - * Results: - * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or - * TCL_PATH_VOLUME_RELATIVE. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_PathType -Tcl_GetPathType( - char *path -) -{ - Tcl_PathType type = TCL_PATH_ABSOLUTE; - - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - /* - * Paths that begin with / or ~ are absolute. - */ - - if ((path[0] != '/') && (path[0] != '~')) { - type = TCL_PATH_RELATIVE; - } - break; - - case TCL_PLATFORM_MAC: - if (path[0] == ':') { - type = TCL_PATH_RELATIVE; - } else if (path[0] != '~') { - - /* - * Since we have eliminated the easy cases, use the - * root pattern to look for the other types. - */ - - if (!macRootPatternPtr) { - macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } - if (!TclRegExec(macRootPatternPtr, path, path) - || (macRootPatternPtr->startp[2] != NULL)) { - type = TCL_PATH_RELATIVE; - } - } - break; - - case TCL_PLATFORM_WINDOWS: - if (path[0] != '~') { - - /* - * Since we have eliminated the easy cases, check for - * drive relative paths using the regular expression. - */ - - if (!winRootPatternPtr) { - winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } - if (TclRegExec(winRootPatternPtr, path, path)) { - if (winRootPatternPtr->startp[5] - || (winRootPatternPtr->startp[2] - && !(winRootPatternPtr->startp[6]))) { - type = TCL_PATH_VOLUME_RELATIVE; - } - } else { - type = TCL_PATH_RELATIVE; - } - } - break; - } - return type; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SplitPath -- - * - * Split a path into a list of path components. The first element - * of the list will have the same path type as the original path. - * - * Results: - * Returns a standard Tcl result. The interpreter result contains - * a list of path components. - * *argvPtr will be filled in with the address of an array - * whose elements point to the elements of path, in order. - * *argcPtr will get filled in with the number of valid elements - * in the array. A single block of memory is dynamically allocated - * to hold both the argv array and a copy of the path elements. - * The caller must eventually free this memory by calling ckfree() - * on *argvPtr. Note: *argvPtr and *argcPtr are only modified - * if the procedure returns normally. - * - * Side effects: - * Allocates memory. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SplitPath( - char *path, /* Pointer to string containing a path. */ - int *argcPtr, /* Pointer to location to fill in with - * the number of elements in the path. */ - char ***argvPtr /* Pointer to place to store pointer to array - * of pointers to path elements. */ -) -{ - int i, size; - char *p; - Tcl_DString buffer; - Tcl_DStringInit(&buffer); - - /* - * Perform platform specific splitting. These routines will leave the - * result in the specified buffer. Individual elements are terminated - * with a null character. - */ - - p = NULL; /* Needed only to prevent gcc warnings. */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - p = SplitUnixPath(path, &buffer); - break; - - case TCL_PLATFORM_WINDOWS: - p = SplitWinPath(path, &buffer); - break; - - case TCL_PLATFORM_MAC: - p = SplitMacPath(path, &buffer); - break; - } - - /* - * Compute the number of elements in the result. - */ - - size = Tcl_DStringLength(&buffer); - *argcPtr = 0; - for (i = 0; i < size; i++) { - if (p[i] == '\0') { - (*argcPtr)++; - } - } - - /* - * Allocate a buffer large enough to hold the contents of the - * DString plus the argv pointers and the terminating NULL pointer. - */ - - *argvPtr = (char **) ckalloc((unsigned) - ((((*argcPtr) + 1) * sizeof(char *)) + size)); - - /* - * Position p after the last argv pointer and copy the contents of - * the DString. - */ - - p = (char *) &(*argvPtr)[(*argcPtr) + 1]; - memcpy((VOID *) p, (VOID *) Tcl_DStringValue(&buffer), (size_t) size); - - /* - * Now set up the argv pointers. - */ - - for (i = 0; i < *argcPtr; i++) { - (*argvPtr)[i] = p; - while ((*p++) != '\0') {} - } - (*argvPtr)[i] = NULL; - - Tcl_DStringFree(&buffer); -} - -/* - *---------------------------------------------------------------------- - * - * SplitUnixPath -- - * - * This routine is used by Tcl_SplitPath to handle splitting - * Unix paths. - * - * Results: - * Stores a null separated array of strings in the specified - * Tcl_DString. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -SplitUnixPath( - char *path, /* Pointer to string containing a path. */ - Tcl_DString *bufPtr /* Pointer to DString to use for the result. */ -) -{ - int length; - char *p, *elementStart; - - /* - * Deal with the root directory as a special case. - */ - - if (path[0] == '/') { - Tcl_DStringAppend(bufPtr, "/", 2); - p = path+1; - } else { - p = path; - } - - /* - * Split on slashes. Embedded elements that start with tilde will be - * prefixed with "./" so they are not affected by tilde substitution. - */ - - for (;;) { - elementStart = p; - while ((*p != '\0') && (*p != '/')) { - p++; - } - length = p - elementStart; - if (length > 0) { - if ((elementStart[0] == '~') && (elementStart != path)) { - Tcl_DStringAppend(bufPtr, "./", 2); - } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); - } - if (*p++ == '\0') { - break; - } - } - return Tcl_DStringValue(bufPtr); -} - -/* - *---------------------------------------------------------------------- - * - * SplitWinPath -- - * - * This routine is used by Tcl_SplitPath to handle splitting - * Windows paths. - * - * Results: - * Stores a null separated array of strings in the specified - * Tcl_DString. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -SplitWinPath( - char *path, /* Pointer to string containing a path. */ - Tcl_DString *bufPtr /* Pointer to DString to use for the result. */ -) -{ - int length; - char *p, *elementStart; - - p = ExtractWinRoot(path, bufPtr, 0); - - /* - * Terminate the root portion, if we matched something. - */ - - if (p != path) { - Tcl_DStringAppend(bufPtr, "", 1); - } - - /* - * Split on slashes. Embedded elements that start with tilde will be - * prefixed with "./" so they are not affected by tilde substitution. - */ - - do { - elementStart = p; - while ((*p != '\0') && (*p != '/') && (*p != '\\')) { - p++; - } - length = p - elementStart; - if (length > 0) { - if ((elementStart[0] == '~') && (elementStart != path)) { - Tcl_DStringAppend(bufPtr, "./", 2); - } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); - } - } while (*p++ != '\0'); - - return Tcl_DStringValue(bufPtr); -} - -/* - *---------------------------------------------------------------------- - * - * SplitMacPath -- - * - * This routine is used by Tcl_SplitPath to handle splitting - * Macintosh paths. - * - * Results: - * Returns a newly allocated argv array. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -SplitMacPath( - char *path, /* Pointer to string containing a path. */ - Tcl_DString *bufPtr /* Pointer to DString to use for the result. */ -) -{ - int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */ - int i, length; - char *p, *elementStart; - - /* - * Initialize the path name parser for Macintosh path names. - */ - - if (macRootPatternPtr == NULL) { - macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } - - /* - * Match the root portion of a Mac path name. - */ - - i = 0; /* Needed only to prevent gcc warnings. */ - if (TclRegExec(macRootPatternPtr, path, path) == 1) { - /* - * Treat degenerate absolute paths like / and /../.. as - * Mac relative file names for lack of anything else to do. - */ - - if (macRootPatternPtr->startp[2] != NULL) { - Tcl_DStringAppend(bufPtr, ":", 1); - Tcl_DStringAppend(bufPtr, path, macRootPatternPtr->endp[0] - - macRootPatternPtr->startp[0] + 1); - return Tcl_DStringValue(bufPtr); - } - - if (macRootPatternPtr->startp[5] != NULL) { - - /* - * Unix-style tilde prefixed paths. - */ - - isMac = 0; - i = 5; - } else if (macRootPatternPtr->startp[7] != NULL) { - - /* - * Mac-style tilde prefixed paths. - */ - - isMac = 1; - i = 7; - } else if (macRootPatternPtr->startp[10] != NULL) { - - /* - * Normal Unix style paths. - */ - - isMac = 0; - i = 10; - } else if (macRootPatternPtr->startp[12] != NULL) { - - /* - * Normal Mac style paths. - */ - - isMac = 1; - i = 12; - } - - length = macRootPatternPtr->endp[i] - - macRootPatternPtr->startp[i]; - - /* - * Append the element and terminate it with a : and a null. Note that - * we are forcing the DString to contain an extra null at the end. - */ - - Tcl_DStringAppend(bufPtr, macRootPatternPtr->startp[i], length); - Tcl_DStringAppend(bufPtr, ":", 2); - p = macRootPatternPtr->endp[i]; - } else { - isMac = (strchr(path, ':') != NULL); - p = path; - } - - if (isMac) { - - /* - * p is pointing at the first colon in the path. There - * will always be one, since this is a Mac-style path. - */ - - elementStart = p++; - while ((p = strchr(p, ':')) != NULL) { - length = p - elementStart; - if (length == 1) { - while (*p == ':') { - Tcl_DStringAppend(bufPtr, "::", 3); - elementStart = p++; - } - } else { - /* - * If this is a simple component, drop the leading colon. - */ - - if ((elementStart[1] != '~') - && (strchr(elementStart+1, '/') == NULL)) { - elementStart++; - length--; - } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); - elementStart = p++; - } - } - if (elementStart[1] != '\0' || elementStart == path) { - if ((elementStart[1] != '~') && (elementStart[1] != '\0') - && (strchr(elementStart+1, '/') == NULL)) { - elementStart++; - } - Tcl_DStringAppend(bufPtr, elementStart, -1); - Tcl_DStringAppend(bufPtr, "", 1); - } - } else { - - /* - * Split on slashes, suppress extra /'s, and convert .. to ::. - */ - - for (;;) { - elementStart = p; - while ((*p != '\0') && (*p != '/')) { - p++; - } - length = p - elementStart; - if (length > 0) { - if ((length == 1) && (elementStart[0] == '.')) { - Tcl_DStringAppend(bufPtr, ":", 2); - } else if ((length == 2) && (elementStart[0] == '.') - && (elementStart[1] == '.')) { - Tcl_DStringAppend(bufPtr, "::", 3); - } else { - if (*elementStart == '~') { - Tcl_DStringAppend(bufPtr, ":", 1); - } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); - } - } - if (*p++ == '\0') { - break; - } - } - } - return Tcl_DStringValue(bufPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_JoinPath -- - * - * Combine a list of paths in a platform specific manner. - * - * Results: - * Appends the joined path to the end of the specified - * returning a pointer to the resulting string. Note that - * the Tcl_DString must already be initialized. - * - * Side effects: - * Modifies the Tcl_DString. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_JoinPath( - int argc, - char **argv, - Tcl_DString *resultPtr /* Pointer to previously initialized DString. */ -) -{ - int oldLength, length, i, needsSep; - Tcl_DString buffer; - char *p, c, *dest; - - Tcl_DStringInit(&buffer); - oldLength = Tcl_DStringLength(resultPtr); - - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - for (i = 0; i < argc; i++) { - p = argv[i]; - /* - * If the path is absolute, reset the result buffer. - * Consume any duplicate leading slashes or a ./ in - * front of a tilde prefixed path that isn't at the - * beginning of the path. - */ - - if (*p == '/') { - Tcl_DStringSetLength(resultPtr, oldLength); - Tcl_DStringAppend(resultPtr, "/", 1); - while (*p == '/') { - p++; - } - } else if (*p == '~') { - Tcl_DStringSetLength(resultPtr, oldLength); - } else if ((Tcl_DStringLength(resultPtr) != oldLength) - && (p[0] == '.') && (p[1] == '/') - && (p[2] == '~')) { - p += 2; - } - - if (*p == '\0') { - continue; - } - - /* - * Append a separator if needed. - */ - - length = Tcl_DStringLength(resultPtr); - if ((length != oldLength) - && (Tcl_DStringValue(resultPtr)[length-1] != '/')) { - Tcl_DStringAppend(resultPtr, "/", 1); - length++; - } - - /* - * Append the element, eliminating duplicate and trailing - * slashes. - */ - - Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p))); - dest = Tcl_DStringValue(resultPtr) + length; - for (; *p != '\0'; p++) { - if (*p == '/') { - while (p[1] == '/') { - p++; - } - if (p[1] != '\0') { - *dest++ = '/'; - } - } else { - *dest++ = *p; - } - } - length = dest - Tcl_DStringValue(resultPtr); - Tcl_DStringSetLength(resultPtr, length); - } - break; - - case TCL_PLATFORM_WINDOWS: - /* - * Iterate over all of the components. If a component is - * absolute, then reset the result and start building the - * path from the current component on. - */ - - for (i = 0; i < argc; i++) { - p = ExtractWinRoot(argv[i], resultPtr, oldLength); - length = Tcl_DStringLength(resultPtr); - - /* - * If the pointer didn't move, then this is a relative path - * or a tilde prefixed path. - */ - - if (p == argv[i]) { - /* - * Remove the ./ from tilde prefixed elements unless - * it is the first component. - */ - - if ((length != oldLength) - && (p[0] == '.') - && ((p[1] == '/') || (p[1] == '\\')) - && (p[2] == '~')) { - p += 2; - } else if (*p == '~') { - Tcl_DStringSetLength(resultPtr, oldLength); - length = oldLength; - } - } - - if (*p != '\0') { - /* - * Check to see if we need to append a separator. - */ - - - if (length != oldLength) { - c = Tcl_DStringValue(resultPtr)[length-1]; - if ((c != '/') && (c != ':')) { - Tcl_DStringAppend(resultPtr, "/", 1); - } - } - - /* - * Append the element, eliminating duplicate and - * trailing slashes. - */ - - length = Tcl_DStringLength(resultPtr); - Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p))); - dest = Tcl_DStringValue(resultPtr) + length; - for (; *p != '\0'; p++) { - if ((*p == '/') || (*p == '\\')) { - while ((p[1] == '/') || (p[1] == '\\')) { - p++; - } - if (p[1] != '\0') { - *dest++ = '/'; - } - } else { - *dest++ = *p; - } - } - length = dest - Tcl_DStringValue(resultPtr); - Tcl_DStringSetLength(resultPtr, length); - } - } - break; - - case TCL_PLATFORM_MAC: - needsSep = 1; - for (i = 0; i < argc; i++) { - Tcl_DStringSetLength(&buffer, 0); - p = SplitMacPath(argv[i], &buffer); - if ((*p != ':') && (*p != '\0') - && (strchr(p, ':') != NULL)) { - Tcl_DStringSetLength(resultPtr, oldLength); - length = strlen(p); - Tcl_DStringAppend(resultPtr, p, length); - needsSep = 0; - p += length+1; - } - - /* - * Now append the rest of the path elements, skipping - * : unless it is the first element of the path, and - * watching out for :: et al. so we don't end up with - * too many colons in the result. - */ - - for (; *p != '\0'; p += length+1) { - if (p[0] == ':' && p[1] == '\0') { - if (Tcl_DStringLength(resultPtr) != oldLength) { - p++; - } else { - needsSep = 0; - } - } else { - c = p[1]; - if (*p == ':') { - if (!needsSep) { - p++; - } - } else { - if (needsSep) { - Tcl_DStringAppend(resultPtr, ":", 1); - } - } - needsSep = (c == ':') ? 0 : 1; - } - length = strlen(p); - Tcl_DStringAppend(resultPtr, p, length); - } - } - break; - - } - Tcl_DStringFree(&buffer); - return Tcl_DStringValue(resultPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_TranslateFileName -- - * - * Converts a file name into a form usable by the native system - * interfaces. If the name starts with a tilde, it will produce - * a name where the tilde and following characters have been - * replaced by the home directory location for the named user. - * - * Results: - * The result is a pointer to a static string containing - * the new name. If there was an error in processing the - * name, then an error message is left in interp->result - * and the return value is NULL. The result will be stored - * in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr) - * to free the name if the return value was not NULL. - * - * Side effects: - * Information may be left in bufferPtr. - * - *---------------------------------------------------------------------- */ - -char * -Tcl_TranslateFileName( - Tcl_Interp *interp, /* Interpreter in which to store error - * message (if necessary). */ - char *name, /* File name, which may begin with "~" - * (to indicate current user's home directory) - * or "~" (to indicate any user's - * 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. */ -) -{ - char *p; - - /* - * Handle tilde substitutions, if needed. - */ - - if (name[0] == '~') { - int argc, length; - char **argv; - Tcl_DString temp; - - Tcl_SplitPath(name, &argc, &argv); - - /* - * Strip the trailing ':' off of a Mac path - * before passing the user name to DoTildeSubst. - */ - - if (tclPlatform == TCL_PLATFORM_MAC) { - length = strlen(argv[0]); - argv[0][length-1] = '\0'; - } - - Tcl_DStringInit(&temp); - argv[0] = DoTildeSubst(interp, argv[0]+1, &temp); - if (argv[0] == NULL) { - Tcl_DStringFree(&temp); - ckfree((char *)argv); - return NULL; - } - Tcl_DStringInit(bufferPtr); - Tcl_JoinPath(argc, argv, bufferPtr); - Tcl_DStringFree(&temp); - ckfree((char*)argv); - } else { - Tcl_DStringInit(bufferPtr); - Tcl_JoinPath(1, &name, bufferPtr); - } - - /* - * Convert forward slashes to backslashes in Windows paths because - * some system interfaces don't accept forward slashes. - */ - - if (tclPlatform == TCL_PLATFORM_WINDOWS) { - for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { - if (*p == '/') { - *p = '\\'; - } - } - } - return Tcl_DStringValue(bufferPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclGetExtension -- - * - * This function returns a pointer to the beginning of the - * extension part of a file name. - * - * Results: - * Returns a pointer into name which indicates where the extension - * starts. If there is no extension, returns NULL. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclGetExtension( - char *name /* File name to parse. */ -) -{ - char *p, *lastSep; - - /* - * First find the last directory separator. - */ - - lastSep = NULL; /* Needed only to prevent gcc warnings. */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - lastSep = strrchr(name, '/'); - break; - - case TCL_PLATFORM_MAC: - if (strchr(name, ':') == NULL) { - lastSep = strrchr(name, '/'); - } else { - lastSep = strrchr(name, ':'); - } - break; - - case TCL_PLATFORM_WINDOWS: - lastSep = NULL; - for (p = name; *p != '\0'; p++) { - if (strchr("/\\:", *p) != NULL) { - lastSep = p; - } - } - break; - } - p = strrchr(name, '.'); - if ((p != NULL) && (lastSep != NULL) - && (lastSep > p)) { - p = NULL; - } - return p; -} - -/* - *---------------------------------------------------------------------- - * - * DoTildeSubst -- - * - * Given a string following a tilde, this routine returns the - * corresponding home directory. - * - * Results: - * The result is a pointer to a static string containing the home - * directory in native format. If there was an error in processing - * the substitution, then an error message is left in interp->result - * and the return value is NULL. On success, the results are appended - * to resultPtr, and the contents of resultPtr are returned. - * - * Side effects: - * Information may be left in resultPtr. - * - *---------------------------------------------------------------------- - */ - -static char * -DoTildeSubst( - Tcl_Interp *interp, /* Interpreter in which to store error - * message (if necessary). */ - char *user, /* Name of user whose home directory should be - * substituted, or "" for current user. */ - Tcl_DString *resultPtr /* May be used to hold result. Must not hold - * anything at the time of the call, and need - * not even be initialized. */ -) -{ - char *dir; - - if (*user == '\0') { - dir = TclGetEnv("HOME"); - if (dir == NULL) { - if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't find HOME environment ", - "variable to expand path", (char *) NULL); - } - return NULL; - } - Tcl_JoinPath(1, &dir, resultPtr); - } else { - if (TclGetUserHome(user, resultPtr) == NULL) { - if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", - (char *) NULL); - } - return NULL; - } - } - return resultPtr->string; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GlobCmd -- - * - * This procedure is invoked to process the "glob" 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_GlobCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int i, noComplain, firstArg; - char c; - int result = TCL_OK; - Tcl_DString buffer; - char *separators, *head, *tail; - - noComplain = 0; - for (firstArg = 1; (firstArg < argc) && (argv[firstArg][0] == '-'); - firstArg++) { - if (strcmp(argv[firstArg], "-nocomplain") == 0) { - noComplain = 1; - } else if (strcmp(argv[firstArg], "--") == 0) { - firstArg++; - break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argv[firstArg], - "\": must be -nocomplain or --", (char *) NULL); - return TCL_ERROR; - } - } - if (firstArg >= argc) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? name ?name ...?\"", (char *) NULL); - return TCL_ERROR; - } - - Tcl_DStringInit(&buffer); - separators = NULL; /* Needed only to prevent gcc warnings. */ - for (i = firstArg; i < argc; i++) { - head = tail = ""; - - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - separators = "/"; - break; - case TCL_PLATFORM_WINDOWS: - separators = "/\\:"; - break; - case TCL_PLATFORM_MAC: - separators = (strchr(argv[i], ':') == NULL) ? "/" : ":"; - break; - } - - Tcl_DStringSetLength(&buffer, 0); - - /* - * Perform tilde substitution, if needed. - */ - - if (argv[i][0] == '~') { - char *p; - - /* - * Find the first path separator after the tilde. - */ - - for (tail = argv[i]; *tail != '\0'; tail++) { - if (*tail == '\\') { - if (strchr(separators, tail[1]) != NULL) { - break; - } - } else if (strchr(separators, *tail) != NULL) { - break; - } - } - - /* - * Determine the home directory for the specified user. Note that - * we don't allow special characters in the user name. - */ - - c = *tail; - *tail = '\0'; - p = strpbrk(argv[i]+1, "\\[]*?{}"); - if (p == NULL) { - head = DoTildeSubst(interp, argv[i]+1, &buffer); - } else { - if (!noComplain) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "globbing characters not ", - "supported in user names", (char *) NULL); - } - head = NULL; - } - *tail = c; - if (head == NULL) { - if (noComplain) { - Tcl_ResetResult(interp); - continue; - } else { - result = TCL_ERROR; - goto done; - } - } - if (head != Tcl_DStringValue(&buffer)) { - Tcl_DStringAppend(&buffer, head, -1); - } - } else { - tail = argv[i]; - } - - result = TclDoGlob(interp, separators, &buffer, tail); - if (result != TCL_OK) { - if (noComplain) { - Tcl_ResetResult(interp); - continue; - } else { - goto done; - } - } - } - - if ((*interp->result == 0) && !noComplain) { - char *sep = ""; - - Tcl_AppendResult(interp, "no files matched glob pattern", - (argc == 2) ? " \"" : "s \"", (char *) NULL); - for (i = firstArg; i < argc; i++) { - Tcl_AppendResult(interp, sep, argv[i], (char *) NULL); - sep = " "; - } - Tcl_AppendResult(interp, "\"", (char *) NULL); - result = TCL_ERROR; - } -done: - Tcl_DStringFree(&buffer); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * SkipToChar -- - * - * This function traverses a glob pattern looking for the next - * unquoted occurrence of the specified character at the same braces - * nesting level. - * - * Results: - * Updates stringPtr to point to the matching character, or to - * the end of the string if nothing matched. The return value - * is 1 if a match was found at the top level, otherwise it is 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -SkipToChar( - char **stringPtr, /* Pointer string to check. */ - char *match /* Pointer to character to find. */ -) -{ - int quoted, level; - char *p; - - quoted = 0; - level = 0; - - for (p = *stringPtr; *p != '\0'; p++) { - if (quoted) { - quoted = 0; - continue; - } - if ((level == 0) && (*p == *match)) { - *stringPtr = p; - return 1; - } - if (*p == '{') { - level++; - } else if (*p == '}') { - level--; - } else if (*p == '\\') { - quoted = 1; - } - } - *stringPtr = p; - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * TclDoGlob -- - * - * This recursive procedure forms the heart of the globbing - * code. It performs a depth-first traversal of the tree - * given by the path name to be globbed. The directory and - * remainder are assumed to be native format paths. - * - * Results: - * The return value is a standard Tcl result indicating whether - * an error occurred in globbing. After a normal return the - * result in interp will be set to hold all of the file names - * given by the dir and rem arguments. After an error the - * result in interp will hold an error message. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclDoGlob( - Tcl_Interp *interp, /* Interpreter to use for error reporting - * (e.g. unmatched brace). */ - char *separators, /* String containing separator characters - * that should be used to identify globbing - * boundaries. */ - Tcl_DString *headPtr, /* Completely expanded prefix. */ - char *tail /* The unexpanded remainder of the path. */ -) -{ - int level, baseLength, quoted, count; - int result = TCL_OK; - char *p, *openBrace, *closeBrace, *name, savedChar; - char lastChar = 0; - int length = Tcl_DStringLength(headPtr); - - if (length > 0) { - lastChar = Tcl_DStringValue(headPtr)[length-1]; - } - - /* - * Consume any leading directory separators, leaving tail pointing - * just past the last initial separator. - */ - - count = 0; - name = tail; - for (; *tail != '\0'; tail++) { - if ((*tail == '\\') && (strchr(separators, tail[1]) != NULL)) { - tail++; - } else if (strchr(separators, *tail) == NULL) { - break; - } - count++; - } - - /* - * Deal with path separators. On the Mac, we have to watch out - * for multiple separators, since they are special in Mac-style - * paths. - */ - - switch (tclPlatform) { - case TCL_PLATFORM_MAC: - if (*separators == '/') { - if (((length == 0) && (count == 0)) - || ((length > 0) && (lastChar != ':'))) { - Tcl_DStringAppend(headPtr, ":", 1); - } - } else { - if (count == 0) { - if ((length > 0) && (lastChar != ':')) { - Tcl_DStringAppend(headPtr, ":", 1); - } - } else { - if (lastChar == ':') { - count--; - } - while (count-- > 0) { - Tcl_DStringAppend(headPtr, ":", 1); - } - } - } - break; - case TCL_PLATFORM_WINDOWS: - /* - * If this is a drive relative path, add the colon and the - * trailing slash if needed. Otherwise add the slash if - * this is the first absolute element, or a later relative - * element. Add an extra slash if this is a UNC path. - */ - - if (*name == ':') { - Tcl_DStringAppend(headPtr, ":", 1); - if (count > 1) { - Tcl_DStringAppend(headPtr, "/", 1); - } - } else if ((*tail != '\0') - && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(headPtr, "/", 1); - if ((length == 0) && (count > 1)) { - Tcl_DStringAppend(headPtr, "/", 1); - } - } - - break; - case TCL_PLATFORM_UNIX: - /* - * Add a separator if this is the first absolute element, or - * a later relative element. - */ - - if ((*tail != '\0') - && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(headPtr, "/", 1); - } - break; - } - - /* - * Look for the first matching pair of braces or the first - * directory separator that is not inside a pair of braces. - */ - - openBrace = closeBrace = NULL; - level = 0; - quoted = 0; - for (p = tail; *p != '\0'; p++) { - if (quoted) { - quoted = 0; - } else if (*p == '\\') { - quoted = 1; - if (strchr(separators, p[1]) != NULL) { - break; /* Quoted directory separator. */ - } - } else if (strchr(separators, *p) != NULL) { - break; /* Unquoted directory separator. */ - } else if (*p == '{') { - openBrace = p; - p++; - if (SkipToChar(&p, "}")) { - closeBrace = p; /* Balanced braces. */ - break; - } - Tcl_ResetResult(interp); - interp->result = "unmatched open-brace in file name"; - return TCL_ERROR; - } else if (*p == '}') { - Tcl_ResetResult(interp); - interp->result = "unmatched close-brace in file name"; - return TCL_ERROR; - } - } - - /* - * Substitute the alternate patterns from the braces and recurse. - */ - - if (openBrace != NULL) { - char *element; - Tcl_DString newName; - Tcl_DStringInit(&newName); - - /* - * For each element within in the outermost pair of braces, - * append the element and the remainder to the fixed portion - * before the first brace and recursively call TclDoGlob. - */ - - Tcl_DStringAppend(&newName, tail, openBrace-tail); - baseLength = Tcl_DStringLength(&newName); - length = Tcl_DStringLength(headPtr); - *closeBrace = '\0'; - for (p = openBrace; p != closeBrace; ) { - p++; - element = p; - SkipToChar(&p, ","); - Tcl_DStringSetLength(headPtr, length); - Tcl_DStringSetLength(&newName, baseLength); - Tcl_DStringAppend(&newName, element, p-element); - Tcl_DStringAppend(&newName, closeBrace+1, -1); - result = TclDoGlob(interp, separators, - headPtr, Tcl_DStringValue(&newName)); - if (result != TCL_OK) { - break; - } - } - *closeBrace = '}'; - Tcl_DStringFree(&newName); - return result; - } - - /* - * At this point, there are no more brace substitutions to perform on - * this path component. The variable p is pointing at a quoted or - * unquoted directory separator or the end of the string. So we need - * to check for special globbing characters in the current pattern. - */ - - savedChar = *p; - *p = '\0'; - - if (strpbrk(tail, "*[]?\\") != NULL) { - *p = savedChar; - /* - * Look for matching files in the current directory. The - * implementation of this function is platform specific, but may - * recursively call TclDoGlob. For each file that matches, it will - * add the match onto the interp->result, or call TclDoGlob if there - * are more characters to be processed. - */ - - return TclMatchFiles(interp, separators, headPtr, tail, p); - } - *p = savedChar; - Tcl_DStringAppend(headPtr, tail, p-tail); - if (*p != '\0') { - return TclDoGlob(interp, separators, headPtr, p); - } - - /* - * There are no more wildcards in the pattern and no more unprocessed - * characters in the tail, so now we can construct the path and verify - * the existence of the file. - */ - - switch (tclPlatform) { - case TCL_PLATFORM_MAC: - if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) { - Tcl_DStringAppend(headPtr, ":", 1); - } - name = Tcl_DStringValue(headPtr); - if (access(name, F_OK) == 0) { - if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) { - Tcl_AppendElement(interp, name+1); - } else { - Tcl_AppendElement(interp, name); - } - } - break; - case TCL_PLATFORM_WINDOWS: { - int exists; - /* - * We need to convert slashes to backslashes before checking - * for the existence of the file. Once we are done, we need - * to convert the slashes back. - */ - - if (Tcl_DStringLength(headPtr) == 0) { - if (((*name == '\\') && (name[1] == '/' || name[1] == '\\')) - || (*name == '/')) { - Tcl_DStringAppend(headPtr, "\\", 1); - } else { - Tcl_DStringAppend(headPtr, ".", 1); - } - } else { - for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) { - if (*p == '/') { - *p = '\\'; - } - } - } - name = Tcl_DStringValue(headPtr); - exists = (access(name, F_OK) == 0); - for (p = name; *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; - } - } - if (exists) { - Tcl_AppendElement(interp, name); - } - break; - } - case TCL_PLATFORM_UNIX: - if (Tcl_DStringLength(headPtr) == 0) { - if ((*name == '\\' && name[1] == '/') || (*name == '/')) { - Tcl_DStringAppend(headPtr, "/", 1); - } else { - Tcl_DStringAppend(headPtr, ".", 1); - } - } - name = Tcl_DStringValue(headPtr); - if (access(name, F_OK) == 0) { - Tcl_AppendElement(interp, name); - } - break; - } - - return TCL_OK; -} diff --git a/cde/programs/dtdocbook/tcl/tclGet.c b/cde/programs/dtdocbook/tcl/tclGet.c deleted file mode 100644 index 38954ac7..00000000 --- a/cde/programs/dtdocbook/tcl/tclGet.c +++ /dev/null @@ -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; -} diff --git a/cde/programs/dtdocbook/tcl/tclHash.c b/cde/programs/dtdocbook/tcl/tclHash.c deleted file mode 100644 index 646f11d5..00000000 --- a/cde/programs/dtdocbook/tcl/tclHash.c +++ /dev/null @@ -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); - } -} diff --git a/cde/programs/dtdocbook/tcl/tclHistory.c b/cde/programs/dtdocbook/tcl/tclHistory.c deleted file mode 100644 index 374c5bc1..00000000 --- a/cde/programs/dtdocbook/tcl/tclHistory.c +++ /dev/null @@ -1,1130 +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: tclHistory.c /main/2 1996/08/08 14:44:19 cde-hp $ */ -/* - * tclHistory.c -- - * - * This module implements history as an optional addition to Tcl. - * It can be called to record commands ("events") before they are - * executed, and it provides a command that may be used to perform - * history substitutions. - * - * 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: @(#) tclHistory.c 1.40 96/02/15 11:50:24 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * This history stuff is mostly straightforward, except for one thing - * that makes everything very complicated. Suppose that the following - * commands get executed: - * echo foo - * history redo - * It's important that the history event recorded for the second command - * be "echo foo", not "history redo". Otherwise, if another "history redo" - * command is typed, it will result in infinite recursions on the - * "history redo" command. Thus, the actual recorded history must be - * echo foo - * echo foo - * To do this, the history command revises recorded history as part of - * its execution. In the example above, when "history redo" starts - * execution, the current event is "history redo", but the history - * command arranges for the current event to be changed to "echo foo". - * - * There are three additional complications. The first is that history - * substitution may only be part of a command, as in the following - * command sequence: - * echo foo bar - * echo [history word 3] - * In this case, the second event should be recorded as "echo bar". Only - * part of the recorded event is to be modified. Fortunately, Tcl_Eval - * helps with this by recording (in the evalFirst and evalLast fields of - * the intepreter) the location of the command being executed, so the - * history module can replace exactly the range of bytes corresponding - * to the history substitution command. - * - * The second complication is that there are two ways to revise history: - * replace a command, and replace the result of a command. Consider the - * two examples below: - * format {result is %d} $num | format {result is %d} $num - * print [history redo] | print [history word 3] - * Recorded history for these two cases should be as follows: - * format {result is %d} $num | format {result is %d} $num - * print [format {result is %d} $num] | print $num - * In the left case, the history command was replaced with another command - * to be executed (the brackets were retained), but in the case on the - * right the result of executing the history command was replaced (i.e. - * brackets were replaced too). - * - * The third complication is that there could potentially be many - * history substitutions within a single command, as in: - * echo [history word 3] [history word 2] - * There could even be nested history substitutions, as in: - * history subs abc [history word 2] - * If history revisions were made immediately during each "history" command - * invocations, it would be very difficult to produce the correct cumulative - * effect from several substitutions in the same command. To get around - * this problem, the actual history revision isn't made during the execution - * of the "history" command. Information about the changes is just recorded, - * in xxx records, and the actual changes are made during the next call to - * Tcl_RecordHistory (when we know that execution of the previous command - * has finished). - */ - -/* - * Default space allocation for command strings: - */ - -#define INITIAL_CMD_SIZE 40 - -/* - * Forward declarations for procedures defined later in this file: - */ - -static void DoRevs _ANSI_ARGS_((Interp *iPtr)); -static HistoryEvent * GetEvent _ANSI_ARGS_((Interp *iPtr, char *string)); -static char * GetWords _ANSI_ARGS_((Interp *iPtr, char *command, - char *words)); -static void InitHistory _ANSI_ARGS_((Interp *iPtr)); -static void InsertRev _ANSI_ARGS_((Interp *iPtr, - HistoryRev *revPtr)); -static void MakeSpace _ANSI_ARGS_((HistoryEvent *hPtr, int size)); -static void RevCommand _ANSI_ARGS_((Interp *iPtr, char *string)); -static void RevResult _ANSI_ARGS_((Interp *iPtr, char *string)); -static int SubsAndEval _ANSI_ARGS_((Interp *iPtr, char *cmd, - char *old, char *new)); - -/* - *---------------------------------------------------------------------- - * - * InitHistory -- - * - * Initialize history-related state in an interpreter. - * - * Results: - * None. - * - * Side effects: - * History info is initialized in iPtr. - * - *---------------------------------------------------------------------- - */ - -static void -InitHistory( - Interp *iPtr /* Interpreter to initialize. */ -) -{ - int i; - - if (iPtr->numEvents != 0) { - return; - } - iPtr->numEvents = 20; - iPtr->events = (HistoryEvent *) - ckalloc((unsigned) (iPtr->numEvents * sizeof(HistoryEvent))); - for (i = 0; i < iPtr->numEvents; i++) { - iPtr->events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); - *iPtr->events[i].command = 0; - iPtr->events[i].bytesAvl = INITIAL_CMD_SIZE; - } - iPtr->curEvent = 0; - iPtr->curEventNum = 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RecordAndEval -- - * - * This procedure adds its command argument to the current list of - * recorded events and then executes the command by calling - * Tcl_Eval. - * - * Results: - * The return value is a standard Tcl return value, the result of - * executing cmd. - * - * Side effects: - * The command is recorded and executed. In addition, pending history - * revisions are carried out, and information is set up to enable - * Tcl_Eval to identify history command ranges. This procedure also - * initializes history information for the interpreter, if it hasn't - * already been initialized. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_RecordAndEval( - Tcl_Interp *interp, /* Token for interpreter in which command - * will be executed. */ - char *cmd, /* Command to record. */ - int flags /* Additional flags. TCL_NO_EVAL means - * only record: don't execute command. - * TCL_EVAL_GLOBAL means use Tcl_GlobalEval - * instead of Tcl_Eval. */ -) -{ - Interp *iPtr = (Interp *) interp; - HistoryEvent *eventPtr; - int length, result; - - if (iPtr->numEvents == 0) { - InitHistory(iPtr); - } - DoRevs(iPtr); - - /* - * Don't record empty commands. - */ - - while (isspace(UCHAR(*cmd))) { - cmd++; - } - if (*cmd == '\0') { - Tcl_ResetResult(interp); - return TCL_OK; - } - - iPtr->curEventNum++; - iPtr->curEvent++; - if (iPtr->curEvent >= iPtr->numEvents) { - iPtr->curEvent = 0; - } - eventPtr = &iPtr->events[iPtr->curEvent]; - - /* - * Chop off trailing newlines before recording the command. - */ - - length = strlen(cmd); - while (cmd[length-1] == '\n') { - length--; - } - MakeSpace(eventPtr, length + 1); - strncpy(eventPtr->command, cmd, (size_t) length); - eventPtr->command[length] = 0; - - /* - * Execute the command. Note: history revision isn't possible after - * a nested call to this procedure, because the event at the top of - * the history list no longer corresponds to what's going on when - * a nested call here returns. Thus, must leave history revision - * disabled when we return. - */ - - result = TCL_OK; - if (!(flags & TCL_NO_EVAL)) { - iPtr->historyFirst = cmd; - iPtr->revDisables = 0; - iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL) | TCL_RECORD_BOUNDS; - if (flags & TCL_EVAL_GLOBAL) { - result = Tcl_GlobalEval(interp, cmd); - } else { - result = Tcl_Eval(interp, cmd); - } - } - iPtr->revDisables = 1; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_HistoryCmd -- - * - * This procedure is invoked to process the "history" 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_HistoryCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Interp *iPtr = (Interp *) interp; - HistoryEvent *eventPtr; - size_t length; - int c; - - if (iPtr->numEvents == 0) { - InitHistory(iPtr); - } - - /* - * If no arguments, treat the same as "history info". - */ - - if (argc == 1) { - goto infoCmd; - } - - c = argv[1][0]; - length = strlen(argv[1]); - - if ((c == 'a') && (strncmp(argv[1], "add", length)) == 0) { - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " add event ?exec?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 4) { - if (strncmp(argv[3], "exec", strlen(argv[3])) != 0) { - Tcl_AppendResult(interp, "bad argument \"", argv[3], - "\": should be \"exec\"", (char *) NULL); - return TCL_ERROR; - } - return Tcl_RecordAndEval(interp, argv[2], 0); - } - return Tcl_RecordAndEval(interp, argv[2], TCL_NO_EVAL); - } else if ((c == 'c') && (strncmp(argv[1], "change", length)) == 0) { - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " change newValue ?event?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - eventPtr = &iPtr->events[iPtr->curEvent]; - iPtr->revDisables += 1; - while (iPtr->revPtr != NULL) { - HistoryRev *nextPtr; - - ckfree(iPtr->revPtr->newBytes); - nextPtr = iPtr->revPtr->nextPtr; - ckfree((char *) iPtr->revPtr); - iPtr->revPtr = nextPtr; - } - } else { - eventPtr = GetEvent(iPtr, argv[3]); - if (eventPtr == NULL) { - return TCL_ERROR; - } - } - MakeSpace(eventPtr, (int) strlen(argv[2]) + 1); - strcpy(eventPtr->command, argv[2]); - return TCL_OK; - } else if ((c == 'e') && (strncmp(argv[1], "event", length)) == 0) { - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " event ?event?\"", (char *) NULL); - return TCL_ERROR; - } - eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); - if (eventPtr == NULL) { - return TCL_ERROR; - } - RevResult(iPtr, eventPtr->command); - Tcl_SetResult(interp, eventPtr->command, TCL_VOLATILE); - return TCL_OK; - } else if ((c == 'i') && (strncmp(argv[1], "info", length)) == 0) { - int count, indx, i; - char *newline; - - if ((argc != 2) && (argc != 3)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " info ?count?\"", (char *) NULL); - return TCL_ERROR; - } - infoCmd: - if (argc == 3) { - if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { - return TCL_ERROR; - } - if (count > iPtr->numEvents) { - count = iPtr->numEvents; - } - } else { - count = iPtr->numEvents; - } - newline = ""; - for (i = 0, indx = iPtr->curEvent + 1 + iPtr->numEvents - count; - i < count; i++, indx++) { - char *cur, *next, savedChar; - char serial[20]; - - if (indx >= iPtr->numEvents) { - indx -= iPtr->numEvents; - } - cur = iPtr->events[indx].command; - if (*cur == '\0') { - continue; /* No command recorded here. */ - } - sprintf(serial, "%6d ", iPtr->curEventNum + 1 - (count - i)); - Tcl_AppendResult(interp, newline, serial, (char *) NULL); - newline = "\n"; - - /* - * Tricky formatting here: for multi-line commands, indent - * the continuation lines. - */ - - while (1) { - next = strchr(cur, '\n'); - if (next == NULL) { - break; - } - next++; - savedChar = *next; - *next = 0; - Tcl_AppendResult(interp, cur, "\t", (char *) NULL); - *next = savedChar; - cur = next; - } - Tcl_AppendResult(interp, cur, (char *) NULL); - } - return TCL_OK; - } else if ((c == 'k') && (strncmp(argv[1], "keep", length)) == 0) { - int count, i, src; - HistoryEvent *events; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " keep number\"", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { - return TCL_ERROR; - } - if ((count <= 0) || (count > 1000)) { - Tcl_AppendResult(interp, "illegal keep count \"", argv[2], - "\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * Create a new history array and copy as much existing history - * as possible from the old array. - */ - - events = (HistoryEvent *) - ckalloc((unsigned) (count * sizeof(HistoryEvent))); - if (count < iPtr->numEvents) { - src = iPtr->curEvent + 1 - count; - if (src < 0) { - src += iPtr->numEvents; - } - } else { - src = iPtr->curEvent + 1; - } - for (i = 0; i < count; i++, src++) { - if (src >= iPtr->numEvents) { - src = 0; - } - if (i < iPtr->numEvents) { - events[i] = iPtr->events[src]; - iPtr->events[src].command = NULL; - } else { - events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); - events[i].command[0] = 0; - events[i].bytesAvl = INITIAL_CMD_SIZE; - } - } - - /* - * Throw away everything left in the old history array, and - * substitute the new one for the old one. - */ - - for (i = 0; i < iPtr->numEvents; i++) { - if (iPtr->events[i].command != NULL) { - ckfree(iPtr->events[i].command); - } - } - ckfree((char *) iPtr->events); - iPtr->events = events; - if (count < iPtr->numEvents) { - iPtr->curEvent = count-1; - } else { - iPtr->curEvent = iPtr->numEvents-1; - } - iPtr->numEvents = count; - return TCL_OK; - } else if ((c == 'n') && (strncmp(argv[1], "nextid", length)) == 0) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " nextid\"", (char *) NULL); - return TCL_ERROR; - } - sprintf(iPtr->result, "%d", iPtr->curEventNum+1); - return TCL_OK; - } else if ((c == 'r') && (strncmp(argv[1], "redo", length)) == 0) { - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " redo ?event?\"", (char *) NULL); - return TCL_ERROR; - } - eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); - if (eventPtr == NULL) { - return TCL_ERROR; - } - RevCommand(iPtr, eventPtr->command); - return Tcl_Eval(interp, eventPtr->command); - } else if ((c == 's') && (strncmp(argv[1], "substitute", length)) == 0) { - if ((argc > 5) || (argc < 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " substitute old new ?event?\"", (char *) NULL); - return TCL_ERROR; - } - eventPtr = GetEvent(iPtr, argc==4 ? "-1" : argv[4]); - if (eventPtr == NULL) { - return TCL_ERROR; - } - return SubsAndEval(iPtr, eventPtr->command, argv[2], argv[3]); - } else if ((c == 'w') && (strncmp(argv[1], "words", length)) == 0) { - char *words; - - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " words num-num/pat ?event?\"", (char *) NULL); - return TCL_ERROR; - } - eventPtr = GetEvent(iPtr, argc==3 ? "-1" : argv[3]); - if (eventPtr == NULL) { - return TCL_ERROR; - } - words = GetWords(iPtr, eventPtr->command, argv[2]); - if (words == NULL) { - return TCL_ERROR; - } - RevResult(iPtr, words); - iPtr->result = words; - iPtr->freeProc = TCL_DYNAMIC; - return TCL_OK; - } - - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be add, change, event, info, keep, nextid, ", - "redo, substitute, or words", (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * MakeSpace -- - * - * Given a history event, make sure it has enough space for - * a string of a given length (enlarge the string area if - * necessary). - * - * Results: - * None. - * - * Side effects: - * More memory may get allocated. - * - *---------------------------------------------------------------------- - */ - -static void -MakeSpace( - HistoryEvent *hPtr, - int size /* # of bytes needed in hPtr. */ -) -{ - if (hPtr->bytesAvl < size) { - ckfree(hPtr->command); - hPtr->command = (char *) ckalloc((unsigned) size); - hPtr->bytesAvl = size; - } -} - -/* - *---------------------------------------------------------------------- - * - * InsertRev -- - * - * Add a new revision to the list of those pending for iPtr. - * Do it in a way that keeps the revision list sorted in - * increasing order of firstIndex. Also, eliminate revisions - * that are subsets of other revisions. - * - * Results: - * None. - * - * Side effects: - * RevPtr is added to iPtr's revision list. - * - *---------------------------------------------------------------------- - */ - -static void -InsertRev( - Interp *iPtr, /* Interpreter to use. */ - HistoryRev *revPtr /* Revision to add to iPtr's list. */ -) -{ - HistoryRev *curPtr; - HistoryRev *prevPtr; - - for (curPtr = iPtr->revPtr, prevPtr = NULL; curPtr != NULL; - prevPtr = curPtr, curPtr = curPtr->nextPtr) { - /* - * If this revision includes the new one (or vice versa) then - * just eliminate the one that is a subset of the other. - */ - - if ((revPtr->firstIndex <= curPtr->firstIndex) - && (revPtr->lastIndex >= curPtr->firstIndex)) { - curPtr->firstIndex = revPtr->firstIndex; - curPtr->lastIndex = revPtr->lastIndex; - curPtr->newSize = revPtr->newSize; - ckfree(curPtr->newBytes); - curPtr->newBytes = revPtr->newBytes; - ckfree((char *) revPtr); - return; - } - if ((revPtr->firstIndex >= curPtr->firstIndex) - && (revPtr->lastIndex <= curPtr->lastIndex)) { - ckfree(revPtr->newBytes); - ckfree((char *) revPtr); - return; - } - - if (revPtr->firstIndex < curPtr->firstIndex) { - break; - } - } - - /* - * Insert revPtr just after prevPtr. - */ - - if (prevPtr == NULL) { - revPtr->nextPtr = iPtr->revPtr; - iPtr->revPtr = revPtr; - } else { - revPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = revPtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * RevCommand -- - * - * This procedure is invoked by the "history" command to record - * a command revision. See the comments at the beginning of the - * file for more information about revisions. - * - * Results: - * None. - * - * Side effects: - * Revision information is recorded. - * - *---------------------------------------------------------------------- - */ - -static void -RevCommand( - Interp *iPtr, /* Interpreter in which to perform the - * substitution. */ - char *string /* String to substitute. */ -) -{ - HistoryRev *revPtr; - - if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { - return; - } - revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); - revPtr->firstIndex = iPtr->evalFirst - iPtr->historyFirst; - revPtr->lastIndex = iPtr->evalLast - iPtr->historyFirst; - revPtr->newSize = strlen(string); - revPtr->newBytes = (char *) ckalloc((unsigned) (revPtr->newSize+1)); - strcpy(revPtr->newBytes, string); - InsertRev(iPtr, revPtr); -} - -/* - *---------------------------------------------------------------------- - * - * RevResult -- - * - * This procedure is invoked by the "history" command to record - * a result revision. See the comments at the beginning of the - * file for more information about revisions. - * - * Results: - * None. - * - * Side effects: - * Revision information is recorded. - * - *---------------------------------------------------------------------- - */ - -static void -RevResult( - Interp *iPtr, /* Interpreter in which to perform the - * substitution. */ - char *string /* String to substitute. */ -) -{ - HistoryRev *revPtr; - char *evalFirst, *evalLast; - char *argv[2]; - - if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { - return; - } - - /* - * Expand the replacement range to include the brackets that surround - * the command. If there aren't any brackets (i.e. this command was - * invoked at top-level) then don't do any revision. Also, if there - * are several commands in brackets, of which this is just one, - * then don't do any revision. - */ - - evalFirst = iPtr->evalFirst; - evalLast = iPtr->evalLast + 1; - while (1) { - if (evalFirst == iPtr->historyFirst) { - return; - } - evalFirst--; - if (*evalFirst == '[') { - break; - } - if (!isspace(UCHAR(*evalFirst))) { - return; - } - } - if (*evalLast != ']') { - return; - } - - revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); - revPtr->firstIndex = evalFirst - iPtr->historyFirst; - revPtr->lastIndex = evalLast - iPtr->historyFirst; - argv[0] = string; - revPtr->newBytes = Tcl_Merge(1, argv); - revPtr->newSize = strlen(revPtr->newBytes); - InsertRev(iPtr, revPtr); -} - -/* - *---------------------------------------------------------------------- - * - * DoRevs -- - * - * This procedure is called to apply the history revisions that - * have been recorded in iPtr. - * - * Results: - * None. - * - * Side effects: - * The most recent entry in the history for iPtr may be modified. - * - *---------------------------------------------------------------------- - */ - -static void -DoRevs( - Interp *iPtr /* Interpreter whose history is to - * be modified. */ -) -{ - HistoryRev *revPtr; - HistoryEvent *eventPtr; - char *newCommand, *p; - unsigned int size; - int bytesSeen, count; - - if (iPtr->revPtr == NULL) { - return; - } - - /* - * The revision is done in two passes. The first pass computes the - * amount of space needed for the revised event, and the second pass - * pieces together the new event and frees up the revisions. - */ - - eventPtr = &iPtr->events[iPtr->curEvent]; - size = strlen(eventPtr->command) + 1; - for (revPtr = iPtr->revPtr; revPtr != NULL; revPtr = revPtr->nextPtr) { - size -= revPtr->lastIndex + 1 - revPtr->firstIndex; - size += revPtr->newSize; - } - - newCommand = (char *) ckalloc(size); - p = newCommand; - bytesSeen = 0; - for (revPtr = iPtr->revPtr; revPtr != NULL; ) { - HistoryRev *nextPtr = revPtr->nextPtr; - - count = revPtr->firstIndex - bytesSeen; - if (count > 0) { - strncpy(p, eventPtr->command + bytesSeen, (size_t) count); - p += count; - } - strncpy(p, revPtr->newBytes, (size_t) revPtr->newSize); - p += revPtr->newSize; - bytesSeen = revPtr->lastIndex+1; - ckfree(revPtr->newBytes); - ckfree((char *) revPtr); - revPtr = nextPtr; - } - strcpy(p, eventPtr->command + bytesSeen); - - /* - * Replace the command in the event. - */ - - ckfree(eventPtr->command); - eventPtr->command = newCommand; - eventPtr->bytesAvl = size; - iPtr->revPtr = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * GetEvent -- - * - * Given a textual description of an event (see the manual page - * for legal values) find the corresponding event and return its - * command string. - * - * Results: - * The return value is a pointer to the event named by "string". - * If no such event exists, then NULL is returned and an error - * message is left in iPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static HistoryEvent * -GetEvent( - Interp *iPtr, /* Interpreter in which to look. */ - char *string /* Description of event. */ -) -{ - int eventNum, index; - HistoryEvent *eventPtr; - int length; - - /* - * First check for a numeric specification of an event. - */ - - if (isdigit(UCHAR(*string)) || (*string == '-')) { - if (Tcl_GetInt((Tcl_Interp *) iPtr, string, &eventNum) != TCL_OK) { - return NULL; - } - if (eventNum < 0) { - eventNum += iPtr->curEventNum; - } - if (eventNum > iPtr->curEventNum) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, - "\" hasn't occurred yet", (char *) NULL); - return NULL; - } - if ((eventNum <= iPtr->curEventNum-iPtr->numEvents) - || (eventNum <= 0)) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, - "\" is too far in the past", (char *) NULL); - return NULL; - } - index = iPtr->curEvent + (eventNum - iPtr->curEventNum); - if (index < 0) { - index += iPtr->numEvents; - } - return &iPtr->events[index]; - } - - /* - * Next, check for an event that contains the string as a prefix or - * that matches the string in the sense of Tcl_StringMatch. - */ - - length = strlen(string); - for (index = iPtr->curEvent - 1; ; index--) { - if (index < 0) { - index += iPtr->numEvents; - } - if (index == iPtr->curEvent) { - break; - } - eventPtr = &iPtr->events[index]; - if ((strncmp(eventPtr->command, string, (size_t) length) == 0) - || Tcl_StringMatch(eventPtr->command, string)) { - return eventPtr; - } - } - - Tcl_AppendResult((Tcl_Interp *) iPtr, "no event matches \"", string, - "\"", (char *) NULL); - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * SubsAndEval -- - * - * Generate a new command by making a textual substitution in - * the "cmd" argument. Then execute the new command. - * - * Results: - * The return value is a standard Tcl error. - * - * Side effects: - * History gets revised if the substitution is occurring on - * a recorded command line. Also, the re-executed command - * may produce side-effects. - * - *---------------------------------------------------------------------- - */ - -static int -SubsAndEval( - Interp *iPtr, /* Interpreter in which to execute - * new command. */ - char *cmd, /* Command in which to substitute. */ - char *old, /* String to search for in command. */ - char *new /* Replacement string for "old". */ -) -{ - char *src, *dst, *newCmd; - int count, oldLength, newLength, length, result; - - /* - * Figure out how much space it will take to hold the - * substituted command (and complain if the old string - * doesn't appear in the original command). - */ - - oldLength = strlen(old); - newLength = strlen(new); - src = cmd; - count = 0; - while (1) { - src = strstr(src, old); - if (src == NULL) { - break; - } - src += oldLength; - count++; - } - if (count == 0) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "\"", old, - "\" doesn't appear in event", (char *) NULL); - return TCL_ERROR; - } - length = strlen(cmd) + count*(newLength - oldLength); - - /* - * Generate a substituted command. - */ - - newCmd = (char *) ckalloc((unsigned) (length + 1)); - dst = newCmd; - while (1) { - src = strstr(cmd, old); - if (src == NULL) { - strcpy(dst, cmd); - break; - } - strncpy(dst, cmd, (size_t) (src-cmd)); - dst += src-cmd; - strcpy(dst, new); - dst += newLength; - cmd = src + oldLength; - } - - RevCommand(iPtr, newCmd); - result = Tcl_Eval((Tcl_Interp *) iPtr, newCmd); - ckfree(newCmd); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * GetWords -- - * - * Given a command string, return one or more words from the - * command string. - * - * Results: - * The return value is a pointer to a dynamically-allocated - * string containing the words of command specified by "words". - * If the word specifier has improper syntax then an error - * message is placed in iPtr->result and NULL is returned. - * - * Side effects: - * Memory is allocated. It is the caller's responsibilty to - * free the returned string.. - * - *---------------------------------------------------------------------- - */ - -static char * -GetWords( - Interp *iPtr, /* Tcl interpreter in which to place - * an error message if needed. */ - char *command, /* Command string. */ - char *words /* Description of which words to extract - * from the command. Either num[-num] or - * a pattern. */ -) -{ - char *result; - char *start, *end, *dst; - char *next; - int first; /* First word desired. -1 means last word - * only. */ - int last; /* Last word desired. -1 means use everything - * up to the end. */ - int index; /* Index of current word. */ - char *pattern; - - /* - * Figure out whether we're looking for a numerical range or for - * a pattern. - */ - - pattern = NULL; - first = 0; - last = -1; - if (*words == '$') { - if (words[1] != '\0') { - goto error; - } - first = -1; - } else if (isdigit(UCHAR(*words))) { - first = strtoul(words, &start, 0); - if (*start == 0) { - last = first; - } else if (*start == '-') { - start++; - if (*start == '$') { - start++; - } else if (isdigit(UCHAR(*start))) { - last = strtoul(start, &start, 0); - } else { - goto error; - } - if (*start != 0) { - goto error; - } - } - if ((first > last) && (last != -1)) { - goto error; - } - } else { - pattern = words; - } - - /* - * Scan through the words one at a time, copying those that are - * relevant into the result string. Allocate a result area large - * enough to hold all the words if necessary. - */ - - result = (char *) ckalloc((unsigned) (strlen(command) + 1)); - dst = result; - for (next = command; isspace(UCHAR(*next)); next++) { - /* Empty loop body: just find start of first word. */ - } - for (index = 0; *next != 0; index++) { - start = next; - end = TclWordEnd(next, 0, (int *) NULL); - if (*end != 0) { - end++; - for (next = end; isspace(UCHAR(*next)); next++) { - /* Empty loop body: just find start of next word. */ - } - } - if ((first > index) || ((first == -1) && (*next != 0))) { - continue; - } - if ((last != -1) && (last < index)) { - continue; - } - if (pattern != NULL) { - int match; - char savedChar = *end; - - *end = 0; - match = Tcl_StringMatch(start, pattern); - *end = savedChar; - if (!match) { - continue; - } - } - if (dst != result) { - *dst = ' '; - dst++; - } - strncpy(dst, start, (size_t) (end-start)); - dst += end-start; - } - *dst = 0; - - /* - * Check for an out-of-range argument index. - */ - - if ((last >= index) || (first >= index)) { - ckfree(result); - Tcl_AppendResult((Tcl_Interp *) iPtr, "word selector \"", words, - "\" specified non-existent words", (char *) NULL); - return NULL; - } - return result; - - error: - Tcl_AppendResult((Tcl_Interp *) iPtr, "bad word selector \"", words, - "\": should be num-num or pattern", (char *) NULL); - return NULL; -} diff --git a/cde/programs/dtdocbook/tcl/tclIO.c b/cde/programs/dtdocbook/tcl/tclIO.c deleted file mode 100644 index 7bd23777..00000000 --- a/cde/programs/dtdocbook/tcl/tclIO.c +++ /dev/null @@ -1,5130 +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: tclIO.c /main/2 1996/08/08 14:44:24 cde-hp $ */ -/* - * tclIO.c -- - * - * This file provides the generic portions (those that are the same on - * all platforms and for all channel types) of Tcl's IO facilities. - * - * 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: @(#) tclIO.c 1.211 96/04/18 09:59:06 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not - * compile on systems where neither is defined. We want both defined so - * that we can test safely for both. In the code we still have to test for - * both because there may be systems on which both are defined and have - * different values. - */ - -#if ((!defined(EWOULDBLOCK)) && (defined(EAGAIN))) -# define EWOULDBLOCK EAGAIN -#endif -#if ((!defined(EAGAIN)) && (defined(EWOULDBLOCK))) -# define EAGAIN EWOULDBLOCK -#endif -#if ((!defined(EAGAIN)) && (!defined(EWOULDBLOCK))) - error one of EWOULDBLOCK or EAGAIN must be defined -#endif - -/* - * struct ChannelBuffer: - * - * Buffers data being sent to or from a channel. - */ - -typedef struct ChannelBuffer { - int nextAdded; /* The next position into which a character - * will be put in the buffer. */ - int nextRemoved; /* Position of next byte to be removed - * from the buffer. */ - int bufSize; /* How big is the buffer? */ - struct ChannelBuffer *nextPtr; - /* Next buffer in chain. */ - char buf[4]; /* Placeholder for real buffer. The real - * buffer occuppies this space + bufSize-4 - * bytes. This must be the last field in - * the structure. */ -} ChannelBuffer; - -#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) - -/* - * The following defines the *default* buffer size for channels. - */ - -#define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4) - -/* - * Structure to record a close callback. One such record exists for - * each close callback registered for a channel. - */ - -typedef struct CloseCallback { - Tcl_CloseProc *proc; /* The procedure to call. */ - ClientData clientData; /* Arbitrary one-word data to pass - * to the callback. */ - struct CloseCallback *nextPtr; /* For chaining close callbacks. */ -} CloseCallback; - -/* - * Forward declaration of Channel; being used in struct EventScriptRecord, - * below. - */ - -typedef struct Channel *ChanPtr; - -/* - * The following structure describes the information saved from a call to - * "fileevent". This is used later when the event being waited for to - * invoke the saved script in the interpreter designed in this record. - */ - -typedef struct EventScriptRecord { - struct Channel *chanPtr; /* The channel for which this script is - * registered. This is used only when an - * error occurs during evaluation of the - * script, to delete the handler. */ - char *script; /* Script to invoke. */ - Tcl_Interp *interp; /* In what interpreter to invoke script? */ - int mask; /* Events must overlap current mask for the - * stored script to be invoked. */ - struct EventScriptRecord *nextPtr; - /* Next in chain of records. */ -} EventScriptRecord; - -/* - * Forward declaration of ChannelHandler; being used in struct Channel, - * below. - */ - -typedef struct ChannelHandler *ChannelHandlerPtr; - -/* - * struct Channel: - * - * One of these structures is allocated for each open channel. It contains data - * specific to the channel but which belongs to the generic part of the Tcl - * channel mechanism, and it points at an instance specific (and type - * specific) * instance data, and at a channel type structure. - */ - -typedef struct Channel { - char *channelName; /* The name of the channel instance in Tcl - * commands. Storage is owned by the generic IO - * code, is dynamically allocated. */ - int flags; /* ORed combination of the flags defined - * below. */ - Tcl_EolTranslation inputTranslation; - /* What translation to apply for end of line - * sequences on input? */ - Tcl_EolTranslation outputTranslation; - /* What translation to use for generating - * end of line sequences in output? */ - int inEofChar; /* If nonzero, use this as a signal of EOF - * on input. */ - int outEofChar; /* If nonzero, append this to the channel - * when it is closed if it is open for - * writing. */ - int unreportedError; /* Non-zero if an error report was deferred - * because it happened in the background. The - * value is the POSIX error code. */ - ClientData instanceData; /* Instance specific data. */ - Tcl_File inFile; /* File to use for input, or NULL. */ - Tcl_File outFile; /* File to use for output, or NULL. */ - Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ - int refCount; /* How many interpreters hold references to - * this IO channel? */ - CloseCallback *closeCbPtr; /* Callbacks registered to be called when the - * channel is closed. */ - ChannelBuffer *curOutPtr; /* Current output buffer being filled. */ - ChannelBuffer *outQueueHead;/* Points at first buffer in output queue. */ - ChannelBuffer *outQueueTail;/* Points at last buffer in output queue. */ - - ChannelBuffer *saveInBufPtr;/* Buffer saved for input queue - eliminates - * need to allocate a new buffer for "gets" - * that crosses buffer boundaries. */ - ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ - ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ - - struct ChannelHandler *chPtr;/* List of channel handlers registered - * for this channel. */ - int interestMask; /* Mask of all events this channel has - * handlers for. */ - struct Channel *nextChanPtr;/* Next in list of channels currently open. */ - EventScriptRecord *scriptRecordPtr; - /* Chain of all scripts registered for - * event handlers ("fileevent") on this - * channel. */ - int bufSize; /* What size buffers to allocate? */ -} Channel; - -/* - * Values for the flags field in Channel. Any ORed combination of the - * following flags can be stored in the field. These flags record various - * options and state bits about the channel. In addition to the flags below, - * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set. - */ - -#define CHANNEL_NONBLOCKING (1<<3) /* Channel is currently in - * nonblocking mode. */ -#define CHANNEL_LINEBUFFERED (1<<4) /* Output to the channel must be - * flushed after every newline. */ -#define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always - * be flushed immediately. */ -#define BUFFER_READY (1<<6) /* Current output buffer (the - * curOutPtr field in the - * channel structure) should be - * output as soon as possible event - * though it may not be full. */ -#define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the - * queued output buffers has been - * scheduled. */ -#define CHANNEL_CLOSED (1<<8) /* Channel has been closed. No - * further Tcl-level IO on the - * channel is allowed. */ -#define CHANNEL_EOF (1<<9) /* EOF occurred on this channel. - * This bit is cleared before every - * input operation. */ -#define CHANNEL_STICKY_EOF (1<<10) /* EOF occurred on this channel because - * we saw the input eofChar. This bit - * prevents clearing of the EOF bit - * before every input operation. */ -#define CHANNEL_BLOCKED (1<<11) /* EWOULDBLOCK or EAGAIN occurred - * on this channel. This bit is - * cleared before every input or - * output operation. */ -#define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input - * translation mode and the last - * byte seen was a "\r". */ - -/* - * For each channel handler registered in a call to Tcl_CreateChannelHandler, - * there is one record of the following type. All of records for a specific - * channel are chained together in a singly linked list which is stored in - * the channel structure. - */ - -typedef struct ChannelHandler { - Channel *chanPtr; /* The channel structure for this channel. */ - int mask; /* Mask of desired events. */ - Tcl_ChannelProc *proc; /* Procedure to call in the type of - * Tcl_CreateChannelHandler. */ - ClientData clientData; /* Argument to pass to procedure. */ - struct ChannelHandler *nextPtr; - /* Next one in list of registered handlers. */ -} ChannelHandler; - -/* - * This structure keeps track of the current ChannelHandler being invoked in - * the current invocation of ChannelHandlerEventProc. There is a potential - * problem if a ChannelHandler is deleted while it is the current one, since - * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this - * problem, structures of the type below indicate the next handler to be - * processed for any (recursively nested) dispatches in progress. The - * nextHandlerPtr field is updated if the handler being pointed to is deleted. - * The nextPtr field is used to chain together all recursive invocations, so - * that Tcl_DeleteChannelHandler can find all the recursively nested - * invocations of ChannelHandlerEventProc and compare the handler being - * deleted against the NEXT handler to be invoked in that invocation; when it - * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr - * field of the structure to the next handler. - */ - -typedef struct NextChannelHandler { - ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in - * this invocation. */ - struct NextChannelHandler *nestedHandlerPtr; - /* Next nested invocation of - * ChannelHandlerEventProc. */ -} NextChannelHandler; - -/* - * This variable holds the list of nested ChannelHandlerEventProc invocations. - */ - -static NextChannelHandler *nestedHandlerPtr = (NextChannelHandler *) NULL; - -/* - * List of all channels currently open. - */ - -static Channel *firstChanPtr = (Channel *) NULL; - -/* - * Has a channel exit handler been created yet? - */ - -static int channelExitHandlerCreated = 0; - -/* - * Has the channel event source been created and registered with the - * notifier? - */ - -static int channelEventSourceCreated = 0; - -/* - * The following structure describes the event that is added to the Tcl - * event queue by the channel handler check procedure. - */ - -typedef struct ChannelHandlerEvent { - Tcl_Event header; /* Standard header for all events. */ - Channel *chanPtr; /* The channel that is ready. */ - int readyMask; /* Events that have occurred. */ -} ChannelHandlerEvent; - -/* - * Static buffer used to sprintf channel option values and return - * them to the caller. - */ - -static char optionVal[128]; - -/* - * Static variables to hold channels for stdin, stdout and stderr. - */ - -static Tcl_Channel stdinChannel = NULL; -static int stdinInitialized = 0; -static Tcl_Channel stdoutChannel = NULL; -static int stdoutInitialized = 0; -static Tcl_Channel stderrChannel = NULL; -static int stderrInitialized = 0; - -/* - * Static functions in this file: - */ - -static int ChannelEventDeleteProc _ANSI_ARGS_(( - Tcl_Event *evPtr, ClientData clientData)); -static void ChannelEventSourceExitProc _ANSI_ARGS_(( - ClientData data)); -static int ChannelHandlerEventProc _ANSI_ARGS_(( - Tcl_Event *evPtr, int flags)); -static void ChannelHandlerCheckProc _ANSI_ARGS_(( - ClientData clientData, int flags)); -static void ChannelHandlerSetupProc _ANSI_ARGS_(( - ClientData clientData, int flags)); -static void ChannelEventScriptInvoker _ANSI_ARGS_(( - ClientData clientData, int flags)); -static int CloseChannel _ANSI_ARGS_((Tcl_Interp *interp, - Channel *chanPtr, int errorCode)); -static void CloseChannelsOnExit _ANSI_ARGS_((ClientData data)); -static int CopyAndTranslateBuffer _ANSI_ARGS_(( - Channel *chanPtr, char *result, int space)); -static void CreateScriptRecord _ANSI_ARGS_(( - Tcl_Interp *interp, Channel *chanPtr, - int mask, char *script)); -static void DeleteChannelTable _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); -static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, - Channel *chanPtr, int mask)); -static void DiscardInputQueued _ANSI_ARGS_(( - Channel *chanPtr, int discardSavedBuffers)); -static void DiscardOutputQueued _ANSI_ARGS_(( - Channel *chanPtr)); -static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp, - Channel *chanPtr, int calledFromAsyncFlush)); -static void FlushEventProc _ANSI_ARGS_((ClientData clientData, - int mask)); -static Tcl_HashTable *GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp)); -static int GetEOL _ANSI_ARGS_((Channel *chanPtr)); -static int GetInput _ANSI_ARGS_((Channel *chanPtr)); -static void RecycleBuffer _ANSI_ARGS_((Channel *chanPtr, - ChannelBuffer *bufPtr, int mustDiscard)); -static void ReturnScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, - Channel *chanPtr, int mask)); -static int ScanBufferForEOL _ANSI_ARGS_((Channel *chanPtr, - ChannelBuffer *bufPtr, - Tcl_EolTranslation translation, int eofChar, - int *bytesToEOLPtr, int *crSeenPtr)); -static int ScanInputForEOL _ANSI_ARGS_((Channel *chanPtr, - int *bytesQueuedPtr)); - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetStdChannel -- - * - * This function is used to change the channels that are used - * for stdin/stdout/stderr in new interpreters. - * - * Results: - * None - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetStdChannel( - Tcl_Channel channel, - int type /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ -) -{ - switch (type) { - case TCL_STDIN: - stdinInitialized = 1; - stdinChannel = channel; - break; - case TCL_STDOUT: - stdoutInitialized = 1; - stdoutChannel = channel; - break; - case TCL_STDERR: - stderrInitialized = 1; - stderrChannel = channel; - break; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetStdChannel -- - * - * Returns the specified standard channel. - * - * Results: - * Returns the specified standard channel, or NULL. - * - * Side effects: - * May cause the creation of a standard channel and the underlying - * file. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_GetStdChannel( - int type /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ -) -{ - Tcl_Channel channel = NULL; - - /* - * If the channels were not created yet, create them now and - * store them in the static variables. Note that we need to set - * stdinInitialized before calling TclGetDefaultStdChannel in order - * to avoid recursive loops when TclGetDefaultStdChannel calls - * Tcl_CreateChannel. - */ - - switch (type) { - case TCL_STDIN: - if (!stdinInitialized) { - stdinInitialized = 1; - stdinChannel = TclGetDefaultStdChannel(TCL_STDIN); - } - channel = stdinChannel; - break; - case TCL_STDOUT: - if (!stdoutInitialized) { - stdoutInitialized = 1; - stdoutChannel = TclGetDefaultStdChannel(TCL_STDOUT); - } - channel = stdoutChannel; - break; - case TCL_STDERR: - if (!stderrInitialized) { - stderrInitialized = 1; - stderrChannel = TclGetDefaultStdChannel(TCL_STDERR); - } - channel = stderrChannel; - break; - } - return channel; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateCloseHandler - * - * Creates a close callback which will be called when the channel is - * closed. - * - * Results: - * None. - * - * Side effects: - * Causes the callback to be called in the future when the channel - * will be closed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CreateCloseHandler( - Tcl_Channel chan, /* The channel for which to create the - * close callback. */ - Tcl_CloseProc *proc, /* The callback routine to call when the - * channel will be closed. */ - ClientData clientData /* Arbitrary data to pass to the - * close callback. */ -) -{ - Channel *chanPtr; - CloseCallback *cbPtr; - - chanPtr = (Channel *) chan; - - cbPtr = (CloseCallback *) ckalloc((unsigned) sizeof(CloseCallback)); - cbPtr->proc = proc; - cbPtr->clientData = clientData; - - cbPtr->nextPtr = chanPtr->closeCbPtr; - chanPtr->closeCbPtr = cbPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteCloseHandler -- - * - * Removes a callback that would have been called on closing - * the channel. If there is no matching callback then this - * function has no effect. - * - * Results: - * None. - * - * Side effects: - * The callback will not be called in the future when the channel - * is eventually closed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteCloseHandler( - Tcl_Channel chan, /* The channel for which to cancel the - * close callback. */ - Tcl_CloseProc *proc, /* The procedure for the callback to - * remove. */ - ClientData clientData /* The callback data for the callback - * to remove. */ -) -{ - Channel *chanPtr; - CloseCallback *cbPtr, *cbPrevPtr; - - chanPtr = (Channel *) chan; - for (cbPtr = chanPtr->closeCbPtr, cbPrevPtr = (CloseCallback *) NULL; - cbPtr != (CloseCallback *) NULL; - cbPtr = cbPtr->nextPtr) { - if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) { - if (cbPrevPtr == (CloseCallback *) NULL) { - chanPtr->closeCbPtr = cbPtr->nextPtr; - } else { - cbPrevPtr = cbPtr->nextPtr; - } - ckfree((char *) cbPtr); - break; - } else { - cbPrevPtr = cbPtr; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * CloseChannelsOnExit -- - * - * Closes all the existing channels, on exit. This routine is called - * during exit processing. - * - * Results: - * None. - * - * Side effects: - * Closes all channels. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -CloseChannelsOnExit( - ClientData clientData /* NULL - unused. */ -) -{ - Channel *chanPtr; /* Iterates over open channels. */ - Channel *nextChanPtr; /* Iterates over open channels. */ - - - for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL; - chanPtr = nextChanPtr) { - nextChanPtr = chanPtr->nextChanPtr; - - /* - * Close it only if the refcount indicates that the channel is not - * referenced from any interpreter. If it is, that interpreter will - * close the channel when it gets destroyed. - */ - - if (chanPtr->refCount <= 0) { - - /* - * Switch the channel back into synchronous mode to ensure that it - * gets flushed now. - */ - - (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, - "-blocking", "on"); - - Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * GetChannelTable -- - * - * Gets and potentially initializes the channel table for an - * interpreter. If it is initializing the table it also inserts - * channels for stdin, stdout and stderr if the interpreter is - * trusted. - * - * Results: - * A pointer to the hash table created, for use by the caller. - * - * Side effects: - * Initializes the channel table for an interpreter. May create - * channels for stdin, stdout and stderr. - * - *---------------------------------------------------------------------- - */ - -static Tcl_HashTable * -GetChannelTable( - Tcl_Interp *interp -) -{ - Tcl_HashTable *hTblPtr; /* Hash table of channels. */ - Tcl_Channel stdinChannel, stdoutChannel, stderrChannel; - - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); - - (void) Tcl_SetAssocData(interp, "tclIO", - (Tcl_InterpDeleteProc *) DeleteChannelTable, - (ClientData) hTblPtr); - - /* - * If the interpreter is trusted (not "safe"), insert channels - * for stdin, stdout and stderr (possibly creating them in the - * process). - */ - - if (Tcl_IsSafe(interp) == 0) { - stdinChannel = Tcl_GetStdChannel(TCL_STDIN); - if (stdinChannel != NULL) { - Tcl_RegisterChannel(interp, stdinChannel); - } - stdoutChannel = Tcl_GetStdChannel(TCL_STDOUT); - if (stdoutChannel != NULL) { - Tcl_RegisterChannel(interp, stdoutChannel); - } - stderrChannel = Tcl_GetStdChannel(TCL_STDERR); - if (stderrChannel != NULL) { - Tcl_RegisterChannel(interp, stderrChannel); - } - } - - } - return hTblPtr; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteChannelTable -- - * - * Deletes the channel table for an interpreter, closing any open - * channels whose refcount reaches zero. This procedure is invoked - * when an interpreter is deleted, via the AssocData cleanup - * mechanism. - * - * Results: - * None. - * - * Side effects: - * Deletes the hash table of channels. May close channels. May flush - * output on closed channels. Removes any channeEvent handlers that were - * registered in this interpreter. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteChannelTable( - ClientData clientData, /* The per-interpreter data structure. */ - Tcl_Interp *interp /* The interpreter being deleted. */ -) -{ - Tcl_HashTable *hTblPtr; /* The hash table. */ - Tcl_HashSearch hSearch; /* Search variable. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Channel *chanPtr; /* Channel being deleted. */ - EventScriptRecord *sPtr, *prevPtr, *nextPtr; - /* Variables to loop over all channel events - * registered, to delete the ones that refer - * to the interpreter being deleted. */ - - /* - * Delete all the registered channels - this will close channels whose - * refcount reaches zero. - */ - - hTblPtr = (Tcl_HashTable *) clientData; - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { - - chanPtr = (Channel *) Tcl_GetHashValue(hPtr); - - /* - * Remove any fileevents registered in this interpreter. - */ - - for (sPtr = chanPtr->scriptRecordPtr, - prevPtr = (EventScriptRecord *) NULL; - sPtr != (EventScriptRecord *) NULL; - sPtr = nextPtr) { - nextPtr = sPtr->nextPtr; - if (sPtr->interp == interp) { - if (prevPtr == (EventScriptRecord *) NULL) { - chanPtr->scriptRecordPtr = nextPtr; - } else { - prevPtr->nextPtr = nextPtr; - } - - Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - ChannelEventScriptInvoker, (ClientData) sPtr); - - Tcl_EventuallyFree((ClientData) sPtr->script, TCL_DYNAMIC); - ckfree((char *) sPtr); - } else { - prevPtr = sPtr; - } - } - - /* - * Cannot call Tcl_UnregisterChannel because that procedure calls - * Tcl_GetAssocData to get the channel table, which might already - * be inaccessible from the interpreter structure. Instead, we - * emulate the behavior of Tcl_UnregisterChannel directly here. - */ - - Tcl_DeleteHashEntry(hPtr); - chanPtr->refCount--; - if (chanPtr->refCount <= 0) { - chanPtr->flags |= CHANNEL_CLOSED; - if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { - Tcl_Close(interp, (Tcl_Channel) chanPtr); - } - } - } - Tcl_DeleteHashTable(hTblPtr); - ckfree((char *) hTblPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UnregisterChannel -- - * - * Deletes the hash entry for a channel associated with an interpreter. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Deletes the hash entry for a channel associated with an interpreter. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_UnregisterChannel( - Tcl_Interp *interp, /* Interpreter in which channel is defined. */ - Tcl_Channel chan /* Channel to delete. */ -) -{ - Tcl_HashTable *hTblPtr; /* Hash table of channels. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Channel *chanPtr; /* The real IO channel. */ - - chanPtr = (Channel *) chan; - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - return TCL_OK; - } - hPtr = Tcl_FindHashEntry(hTblPtr, chanPtr->channelName); - if (hPtr == (Tcl_HashEntry *) NULL) { - return TCL_OK; - } - if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { - return TCL_OK; - } - Tcl_DeleteHashEntry(hPtr); - chanPtr->refCount--; - if (chanPtr->refCount <= 0) { - chanPtr->flags |= CHANNEL_CLOSED; - if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { - if (Tcl_Close(interp, chan) != TCL_OK) { - return TCL_ERROR; - } - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RegisterChannel -- - * - * Adds an already-open channel to the channel table of an interpreter. - * - * Results: - * None. - * - * Side effects: - * May increment the reference count of a channel. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_RegisterChannel( - Tcl_Interp *interp, /* Interpreter in which to add the channel. */ - Tcl_Channel chan /* The channel to add to this interpreter - * channel table. */ -) -{ - Tcl_HashTable *hTblPtr; /* Hash table of channels. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - int new; /* Is the hash entry new or does it exist? */ - Channel *chanPtr; /* The actual channel. */ - - chanPtr = (Channel *) chan; - - if (chanPtr->channelName == (char *) NULL) { - panic("Tcl_RegisterChannel: channel without name"); - } - hTblPtr = GetChannelTable(interp); - hPtr = Tcl_CreateHashEntry(hTblPtr, chanPtr->channelName, &new); - if (new == 0) { - if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { - return; - } - panic("Tcl_RegisterChannel: duplicate channel names"); - } - Tcl_SetHashValue(hPtr, (ClientData) chanPtr); - chanPtr->refCount++; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetChannel -- - * - * Finds an existing Tcl_Channel structure by name in a given - * interpreter. This function is public because it is used by - * channel-type-specific functions. - * - * Results: - * A Tcl_Channel or NULL on failure. If failed, interp->result - * contains an error message. It also returns, in modePtr, the - * modes in which the channel is opened. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_GetChannel( - Tcl_Interp *interp, /* Interpreter in which to find or create - * the channel. */ - char *chanName, /* The name of the channel. */ - int *modePtr /* Where to store the mode in which the - * channel was opened? Will contain an ORed - * combination of TCL_READABLE and - * TCL_WRITABLE, if non-NULL. */ -) -{ - Channel *chanPtr; /* The actual channel. */ - Tcl_HashTable *hTblPtr; /* Hash table of channels. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - char *name; /* Translated name. */ - - /* - * Substitute "stdin", etc. Note that even though we immediately - * find the channel using Tcl_GetStdChannel, we still need to look - * it up in the specified interpreter to ensure that it is present - * in the channel table. Otherwise, safe interpreters would always - * have access to the standard channels. - */ - - name = chanName; - if ((chanName[0] == 's') && (chanName[1] == 't')) { - chanPtr = NULL; - if (strcmp(chanName, "stdin") == 0) { - chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDIN); - } else if (strcmp(chanName, "stdout") == 0) { - chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDOUT); - } else if (strcmp(chanName, "stderr") == 0) { - chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDERR); - } - if (chanPtr != NULL) { - name = chanPtr->channelName; - } - } - - hTblPtr = GetChannelTable(interp); - hPtr = Tcl_FindHashEntry(hTblPtr, name); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendResult(interp, "can not find channel named \"", - chanName, "\"", (char *) NULL); - return NULL; - } - - chanPtr = (Channel *) Tcl_GetHashValue(hPtr); - if (modePtr != NULL) { - *modePtr = (chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)); - } - - return (Tcl_Channel) chanPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateChannel -- - * - * Creates a new entry in the hash table for a Tcl_Channel - * record. - * - * Results: - * Returns the new Tcl_Channel. - * - * Side effects: - * Creates a new Tcl_Channel instance and inserts it into the - * hash table. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_CreateChannel( - Tcl_ChannelType *typePtr, /* The channel type record. */ - char *chanName, /* Name of channel to record. */ - Tcl_File inFile, /* File to use for input, or NULL. */ - Tcl_File outFile, /* File to use for output, or NULL. */ - ClientData instanceData /* Instance specific data. */ -) -{ - Channel *chanPtr; /* The channel structure newly created. */ - - chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); - - if (chanName != (char *) NULL) { - chanPtr->channelName = ckalloc((unsigned) (strlen(chanName) + 1)); - strcpy(chanPtr->channelName, chanName); - } else { - panic("Tcl_CreateChannel: NULL channel name"); - } - - chanPtr->flags = 0; - if (inFile != (Tcl_File) NULL) { - chanPtr->flags |= TCL_READABLE; - } - if (outFile != (Tcl_File) NULL) { - chanPtr->flags |= TCL_WRITABLE; - } - - /* - * Set the channel up initially in AUTO input translation mode to - * accept "\n", "\r" and "\r\n". Output translation mode is set to - * a platform specific default value. The eofChar is set to 0 for both - * input and output, so that Tcl does not look for an in-file EOF - * indicator (e.g. ^Z) and does not append an EOF indicator to files. - */ - - chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; - chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; - chanPtr->inEofChar = 0; - chanPtr->outEofChar = 0; - - chanPtr->unreportedError = 0; - chanPtr->instanceData = instanceData; - chanPtr->inFile = inFile; - chanPtr->outFile = outFile; - chanPtr->typePtr = typePtr; - chanPtr->refCount = 0; - chanPtr->closeCbPtr = (CloseCallback *) NULL; - chanPtr->curOutPtr = (ChannelBuffer *) NULL; - chanPtr->outQueueHead = (ChannelBuffer *) NULL; - chanPtr->outQueueTail = (ChannelBuffer *) NULL; - chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; - chanPtr->inQueueHead = (ChannelBuffer *) NULL; - chanPtr->inQueueTail = (ChannelBuffer *) NULL; - chanPtr->chPtr = (ChannelHandler *) NULL; - chanPtr->interestMask = 0; - chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; - chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; - - /* - * Link the channel into the list of all channels; create an on-exit - * handler if there is not one already, to close off all the channels - * in the list on exit. - */ - - chanPtr->nextChanPtr = firstChanPtr; - firstChanPtr = chanPtr; - - if (!channelExitHandlerCreated) { - channelExitHandlerCreated = 1; - Tcl_CreateExitHandler(CloseChannelsOnExit, (ClientData) NULL); - } - - /* - * Install this channel in the first empty standard channel slot. - */ - - if (Tcl_GetStdChannel(TCL_STDIN) == NULL) { - Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDIN); - } else if (Tcl_GetStdChannel(TCL_STDOUT) == NULL) { - Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDOUT); - } else if (Tcl_GetStdChannel(TCL_STDERR) == NULL) { - Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDERR); - } - - return (Tcl_Channel) chanPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetChannelName -- - * - * Returns the string identifying the channel name. - * - * Results: - * The string containing the channel name. This memory is - * owned by the generic layer and should not be modified by - * the caller. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_GetChannelName( - Tcl_Channel chan /* The channel for which to return the name. */ -) -{ - Channel *chanPtr; /* The actual channel. */ - - chanPtr = (Channel *) chan; - return chanPtr->channelName; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetChannelType -- - * - * Given a channel structure, returns the channel type structure. - * - * Results: - * Returns a pointer to the channel type structure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_ChannelType * -Tcl_GetChannelType( - Tcl_Channel chan /* The channel to return type for. */ -) -{ - Channel *chanPtr; /* The actual channel. */ - - chanPtr = (Channel *) chan; - return chanPtr->typePtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetChannelFile -- - * - * Returns a file associated with a channel. - * - * Results: - * The file or NULL if failed (e.g. the channel is not open for the - * requested direction). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_File -Tcl_GetChannelFile( - Tcl_Channel chan, /* The channel to get file from. */ - int direction /* TCL_WRITABLE or TCL_READABLE. */ -) -{ - Channel *chanPtr; /* The actual channel. */ - - chanPtr = (Channel *) chan; - switch (direction) { - case TCL_WRITABLE: - return chanPtr->outFile; - case TCL_READABLE: - return chanPtr->inFile; - default: - return NULL; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetChannelInstanceData -- - * - * Returns the client data associated with a channel. - * - * Results: - * The client data. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_GetChannelInstanceData( - Tcl_Channel chan /* Channel for which to return client data. */ -) -{ - Channel *chanPtr; /* The actual channel. */ - - chanPtr = (Channel *) chan; - return chanPtr->instanceData; -} - -/* - *---------------------------------------------------------------------- - * - * RecycleBuffer -- - * - * Helper function to recycle input and output buffers. Ensures - * that two input buffers are saved (one in the input queue and - * another in the saveInBufPtr field) and that curOutPtr is set - * to a buffer. Only if these conditions are met is the buffer - * freed to the OS. - * - * Results: - * None. - * - * Side effects: - * May free a buffer to the OS. - * - *---------------------------------------------------------------------- - */ - -static void -RecycleBuffer( - Channel *chanPtr, /* Channel for which to recycle buffers. */ - ChannelBuffer *bufPtr, /* The buffer to recycle. */ - int mustDiscard /* If nonzero, free the buffer to the - * OS, always. */ -) -{ - /* - * Do we have to free the buffer to the OS? - */ - - if (mustDiscard) { - ckfree((char *) bufPtr); - return; - } - - /* - * Only save buffers for the input queue if the channel is readable. - */ - - if (chanPtr->flags & TCL_READABLE) { - if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { - chanPtr->inQueueHead = bufPtr; - chanPtr->inQueueTail = bufPtr; - goto keepit; - } - if (chanPtr->saveInBufPtr == (ChannelBuffer *) NULL) { - chanPtr->saveInBufPtr = bufPtr; - goto keepit; - } - } - - /* - * Only save buffers for the output queue if the channel is writable. - */ - - if (chanPtr->flags & TCL_WRITABLE) { - if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { - chanPtr->curOutPtr = bufPtr; - goto keepit; - } - } - - /* - * If we reached this code we return the buffer to the OS. - */ - - ckfree((char *) bufPtr); - return; - -keepit: - bufPtr->nextRemoved = 0; - bufPtr->nextAdded = 0; - bufPtr->nextPtr = (ChannelBuffer *) NULL; -} - -/* - *---------------------------------------------------------------------- - * - * DiscardOutputQueued -- - * - * Discards all output queued in the output queue of a channel. - * - * Results: - * None. - * - * Side effects: - * Recycles buffers. - * - *---------------------------------------------------------------------- - */ - -static void -DiscardOutputQueued( - Channel *chanPtr /* The channel for which to discard output. */ -) -{ - ChannelBuffer *bufPtr; - - while (chanPtr->outQueueHead != (ChannelBuffer *) NULL) { - bufPtr = chanPtr->outQueueHead; - chanPtr->outQueueHead = bufPtr->nextPtr; - RecycleBuffer(chanPtr, bufPtr, 0); - } - chanPtr->outQueueHead = (ChannelBuffer *) NULL; - chanPtr->outQueueTail = (ChannelBuffer *) NULL; -} - -/* - *---------------------------------------------------------------------- - * - * FlushChannel -- - * - * This function flushes as much of the queued output as is possible - * now. If calledFromAsyncFlush is nonzero, it is being called in an - * event handler to flush channel output asynchronously. - * - * Results: - * 0 if successful, else the error code that was returned by the - * channel type operation. - * - * Side effects: - * May produce output on a channel. May block indefinitely if the - * channel is synchronous. May schedule an async flush on the channel. - * May recycle memory for buffers in the output queue. - * - *---------------------------------------------------------------------- - */ - -static int -FlushChannel( - Tcl_Interp *interp, /* For error reporting during close. */ - Channel *chanPtr, /* The channel to flush on. */ - int calledFromAsyncFlush /* If nonzero then we are being - * called from an asynchronous - * flush callback. */ -) -{ - ChannelBuffer *bufPtr; /* Iterates over buffered output - * queue. */ - int toWrite; /* Amount of output data in current - * buffer available to be written. */ - int written; /* Amount of output data actually - * written in current round. */ - int errorCode; /* Stores POSIX error codes from - * channel driver operations. */ - - errorCode = 0; - - /* - * Loop over the queued buffers and attempt to flush as - * much as possible of the queued output to the channel. - */ - - while (1) { - - /* - * If the queue is empty and there is a ready current buffer, OR if - * the current buffer is full, then move the current buffer to the - * queue. - */ - - if (((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && - (chanPtr->curOutPtr->nextAdded == chanPtr->curOutPtr->bufSize)) - || ((chanPtr->flags & BUFFER_READY) && - (chanPtr->outQueueHead == (ChannelBuffer *) NULL))) { - chanPtr->flags &= (~(BUFFER_READY)); - chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; - if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { - chanPtr->outQueueHead = chanPtr->curOutPtr; - } else { - chanPtr->outQueueTail->nextPtr = chanPtr->curOutPtr; - } - chanPtr->outQueueTail = chanPtr->curOutPtr; - chanPtr->curOutPtr = (ChannelBuffer *) NULL; - } - bufPtr = chanPtr->outQueueHead; - - /* - * If we are not being called from an async flush and an async - * flush is active, we just return without producing any output. - */ - - if ((!calledFromAsyncFlush) && - (chanPtr->flags & BG_FLUSH_SCHEDULED)) { - return 0; - } - - /* - * If the output queue is still empty, break out of the while loop. - */ - - if (bufPtr == (ChannelBuffer *) NULL) { - break; /* Out of the "while (1)". */ - } - - /* - * Produce the output on the channel. - */ - - toWrite = bufPtr->nextAdded - bufPtr->nextRemoved; - written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData, - chanPtr->outFile, bufPtr->buf + bufPtr->nextRemoved, - toWrite, &errorCode); - - /* - * If the write failed completely attempt to start the asynchronous - * flush mechanism and break out of this loop - do not attempt to - * write any more output at this time. - */ - - if (written < 0) { - - /* - * If the last attempt to write was interrupted, simply retry. - */ - - if (errorCode == EINTR) { - continue; - } - - /* - * If we would have blocked, attempt to set up an asynchronous - * background flushing for this channel if the channel is - * nonblocking, or block until more output can be written if - * the channel is blocking. - */ - - if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) { - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { - Tcl_CreateFileHandler(chanPtr->outFile, - TCL_WRITABLE, FlushEventProc, - (ClientData) chanPtr); - } - chanPtr->flags |= BG_FLUSH_SCHEDULED; - errorCode = 0; - break; /* Out of the "while (1)" loop. */ - } else { - - /* - * If the device driver did not emulate blocking behavior - * then we must do it it here. - */ - - TclWaitForFile(chanPtr->outFile, TCL_WRITABLE, -1); - continue; - } - } - - /* - * Decide whether to report the error upwards or defer it. If - * we got an error during async flush we discard all queued - * output. - */ - - if (calledFromAsyncFlush) { - if (chanPtr->unreportedError == 0) { - chanPtr->unreportedError = errorCode; - } - } else { - Tcl_SetErrno(errorCode); - } - - /* - * When we get an error we throw away all the output - * currently queued. - */ - - DiscardOutputQueued(chanPtr); - continue; - } - - bufPtr->nextRemoved += written; - - /* - * If this buffer is now empty, recycle it. - */ - - if (bufPtr->nextRemoved == bufPtr->nextAdded) { - chanPtr->outQueueHead = bufPtr->nextPtr; - if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { - chanPtr->outQueueTail = (ChannelBuffer *) NULL; - } - RecycleBuffer(chanPtr, bufPtr, 0); - } - } /* Closes "while (1)". */ - - /* - * If the queue became empty and we have an asynchronous flushing - * mechanism active, cancel the asynchronous flushing. - */ - - if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && - (chanPtr->flags & BG_FLUSH_SCHEDULED)) { - chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); - if (chanPtr->outFile != (Tcl_File) NULL) { - Tcl_DeleteFileHandler(chanPtr->outFile); - } - } - - /* - * If the channel is flagged as closed, delete it when the refcount - * drops to zero, the output queue is empty and there is no output - * in the current output buffer. - */ - - if ((chanPtr->flags & CHANNEL_CLOSED) && (chanPtr->refCount <= 0) && - (chanPtr->outQueueHead == (ChannelBuffer *) NULL) && - ((chanPtr->curOutPtr == (ChannelBuffer *) NULL) || - (chanPtr->curOutPtr->nextAdded == - chanPtr->curOutPtr->nextRemoved))) { - return CloseChannel(interp, chanPtr, errorCode); - } - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * CloseChannel -- - * - * Utility procedure to close a channel and free its associated - * resources. - * - * Results: - * 0 on success or a POSIX error code if the operation failed. - * - * Side effects: - * May close the actual channel; may free memory. - * - *---------------------------------------------------------------------- - */ - -static int -CloseChannel( - Tcl_Interp *interp, /* For error reporting. */ - Channel *chanPtr, /* The channel to close. */ - int errorCode /* Status of operation so far. */ -) -{ - int result; /* Of calling driver close - * operation. */ - Channel *prevChanPtr; /* Preceding channel in list of - * all channels - used to splice a - * channel out of the list on close. */ - - /* - * No more input can be consumed so discard any leftover input. - */ - - DiscardInputQueued(chanPtr, 1); - - /* - * Discard a leftover buffer in the current output buffer field. - */ - - if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { - ckfree((char *) chanPtr->curOutPtr); - chanPtr->curOutPtr = (ChannelBuffer *) NULL; - } - - /* - * The caller guarantees that there are no more buffers - * queued for output. - */ - - if (chanPtr->outQueueHead != (ChannelBuffer *) NULL) { - panic("TclFlush, closed channel: queued output left"); - } - - /* - * If the EOF character is set in the channel, append that to the - * output device. - */ - - if ((chanPtr->outEofChar != 0) && (chanPtr->outFile != NULL)) { - int dummy; - char c; - - c = (char) chanPtr->outEofChar; - (chanPtr->typePtr->outputProc) (chanPtr->instanceData, - chanPtr->outFile, &c, 1, &dummy); - } - - /* - * Remove TCL_READABLE and TCL_WRITABLE from chanPtr->flags, so - * that close callbacks can not do input or output (assuming they - * squirreled the channel away in their clientData). This also - * prevents infinite loops if the callback calls any C API that - * could call FlushChannel. - */ - - chanPtr->flags &= (~(TCL_READABLE|TCL_WRITABLE)); - - /* - * Splice this channel out of the list of all channels. - */ - - if (chanPtr == firstChanPtr) { - firstChanPtr = chanPtr->nextChanPtr; - } else { - for (prevChanPtr = firstChanPtr; - (prevChanPtr != (Channel *) NULL) && - (prevChanPtr->nextChanPtr != chanPtr); - prevChanPtr = prevChanPtr->nextChanPtr) { - /* Empty loop body. */ - } - if (prevChanPtr == (Channel *) NULL) { - panic("FlushChannel: damaged channel list"); - } - prevChanPtr->nextChanPtr = chanPtr->nextChanPtr; - } - - if (chanPtr->channelName != (char *) NULL) { - ckfree(chanPtr->channelName); - } - - /* - * OK, close the channel itself. - */ - - result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp, - chanPtr->inFile, chanPtr->outFile); - - /* - * If we are being called synchronously, report either - * any latent error on the channel or the current error. - */ - - if (chanPtr->unreportedError != 0) { - errorCode = chanPtr->unreportedError; - } - if (errorCode == 0) { - errorCode = result; - if (errorCode != 0) { - Tcl_SetErrno(errorCode); - } - } - - Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); - - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Close -- - * - * Closes a channel. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Closes the channel if this is the last reference. - * - * NOTE: - * Tcl_Close removes the channel as far as the user is concerned. - * However, it may continue to exist for a while longer if it has - * a background flush scheduled. The device itself is eventually - * closed and the channel record removed, in CloseChannel, above. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_Close( - Tcl_Interp *interp, /* Interpreter for errors. */ - Tcl_Channel chan /* The channel being closed. Must - * not be referenced in any - * interpreter. */ -) -{ - ChannelHandler *chPtr, *chNext; /* Iterate over channel handlers. */ - CloseCallback *cbPtr; /* Iterate over close callbacks - * for this channel. */ - EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */ - Channel *chanPtr; /* The real IO channel. */ - int result; /* Of calling FlushChannel. */ - - chanPtr = (Channel *) chan; - - if (chanPtr->refCount > 0) { - panic("called Tcl_Close on channel with refcount > 0"); - } - - /* - * Remove the channel from the standard channel table. - */ - - if (Tcl_GetStdChannel(TCL_STDIN) == chan) { - Tcl_SetStdChannel(NULL, TCL_STDIN); - } else if (Tcl_GetStdChannel(TCL_STDOUT) == chan) { - Tcl_SetStdChannel(NULL, TCL_STDOUT); - } else if (Tcl_GetStdChannel(TCL_STDERR) == chan) { - Tcl_SetStdChannel(NULL, TCL_STDERR); - } - - /* - * Remove all the channel handler records attached to the channel - * itself. - */ - - for (chPtr = chanPtr->chPtr; - chPtr != (ChannelHandler *) NULL; - chPtr = chNext) { - chNext = chPtr->nextPtr; - ckfree((char *) chPtr); - } - chanPtr->chPtr = (ChannelHandler *) NULL; - - /* - * Must set the interest mask now to 0, otherwise infinite loops - * will occur if Tcl_DoOneEvent is called before the channel is - * finally deleted in FlushChannel. This can happen if the channel - * has a background flush active. - */ - - chanPtr->interestMask = 0; - - /* - * Remove any EventScript records for this channel. - */ - - for (ePtr = chanPtr->scriptRecordPtr; - ePtr != (EventScriptRecord *) NULL; - ePtr = eNextPtr) { - eNextPtr = ePtr->nextPtr; - Tcl_EventuallyFree((ClientData)ePtr->script, TCL_DYNAMIC); - ckfree((char *) ePtr); - } - chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; - - /* - * Invoke the registered close callbacks and delete their records. - */ - - while (chanPtr->closeCbPtr != (CloseCallback *) NULL) { - cbPtr = chanPtr->closeCbPtr; - chanPtr->closeCbPtr = cbPtr->nextPtr; - (cbPtr->proc) (cbPtr->clientData); - ckfree((char *) cbPtr); - } - - /* - * And remove any events for this channel from the event queue. - */ - - Tcl_DeleteEvents(ChannelEventDeleteProc, (ClientData) chanPtr); - - /* - * Ensure that the last output buffer will be flushed. - */ - - if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && - (chanPtr->curOutPtr->nextAdded > chanPtr->curOutPtr->nextRemoved)) { - chanPtr->flags |= BUFFER_READY; - } - - /* - * The call to FlushChannel will flush any queued output and invoke - * the close function of the channel driver, or it will set up the - * channel to be flushed and closed asynchronously. - */ - - chanPtr->flags |= CHANNEL_CLOSED; - result = FlushChannel(interp, chanPtr, 0); - if (result != 0) { - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ChannelEventDeleteProc -- - * - * This procedure returns 1 if the event passed in is for the - * channel passed in as the second argument. This procedure is - * used as a filter for events to delete in a call to - * Tcl_DeleteEvents in CloseChannel. - * - * Results: - * 1 if matching, 0 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ChannelEventDeleteProc( - Tcl_Event *evPtr, /* The event to check for a match. */ - ClientData clientData /* The channel to check for. */ -) -{ - ChannelHandlerEvent *cEvPtr; - Channel *chanPtr; - - if (evPtr->proc != ChannelHandlerEventProc) { - return 0; - } - cEvPtr = (ChannelHandlerEvent *) evPtr; - chanPtr = (Channel *) clientData; - if (cEvPtr->chanPtr != chanPtr) { - return 0; - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Write -- - * - * Puts a sequence of characters into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. - * - * Results: - * The number of bytes written or -1 in case of error. If -1, - * Tcl_GetErrno will return the error code. - * - * Side effects: - * May buffer up output and may cause output to be produced on the - * channel. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Write( - Tcl_Channel chan, /* The channel to buffer output for. */ - char *srcPtr, /* Output to buffer. */ - int slen /* Its length. Negative means - * the output is null terminated - * and we must compute its length. */ -) -{ - Channel *chanPtr; /* The actual channel. */ - ChannelBuffer *outBufPtr; /* Current output buffer. */ - int foundNewline; /* Did we find a newline in output? */ - char *dPtr, *sPtr; /* Search variables for newline. */ - int crsent; /* In CRLF eol translation mode, - * remember the fact that a CR was - * output to the channel without - * its following NL. */ - int i; /* Loop index for newline search. */ - int destCopied; /* How many bytes were used in this - * destination buffer to hold the - * output? */ - int totalDestCopied; /* How many bytes total were - * copied to the channel buffer? */ - int srcCopied; /* How many bytes were copied from - * the source string? */ - char *destPtr; /* Where in line to copy to? */ - - chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; - } - - /* - * If the channel is not open for writing punt. - */ - - if (!(chanPtr->flags & TCL_WRITABLE)) { - Tcl_SetErrno(EACCES); - return -1; - } - - /* - * If length passed is negative, assume that the output is null terminated - * and compute its length. - */ - - if (slen < 0) { - slen = strlen(srcPtr); - } - - /* - * If we are in network (or windows) translation mode, record the fact - * that we have not yet sent a CR to the channel. - */ - - crsent = 0; - - /* - * Loop filling buffers and flushing them until all output has been - * consumed. - */ - - srcCopied = 0; - totalDestCopied = 0; - - while (slen > 0) { - - /* - * Make sure there is a current output buffer to accept output. - */ - - if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { - chanPtr->curOutPtr = (ChannelBuffer *) ckalloc((unsigned) - (CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); - chanPtr->curOutPtr->nextAdded = 0; - chanPtr->curOutPtr->nextRemoved = 0; - chanPtr->curOutPtr->bufSize = chanPtr->bufSize; - chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; - } - - outBufPtr = chanPtr->curOutPtr; - - destCopied = outBufPtr->bufSize - outBufPtr->nextAdded; - if (destCopied > slen) { - destCopied = slen; - } - - destPtr = outBufPtr->buf + outBufPtr->nextAdded; - switch (chanPtr->outputTranslation) { - case TCL_TRANSLATE_LF: - srcCopied = destCopied; - memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); - break; - case TCL_TRANSLATE_CR: - srcCopied = destCopied; - memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); - for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { - if (*dPtr == '\n') { - *dPtr = '\r'; - } - } - break; - case TCL_TRANSLATE_CRLF: - for (srcCopied = 0, dPtr = destPtr, sPtr = srcPtr; - dPtr < destPtr + destCopied; - dPtr++, sPtr++, srcCopied++) { - if (*sPtr == '\n') { - if (crsent) { - *dPtr = '\n'; - crsent = 0; - } else { - *dPtr = '\r'; - crsent = 1; - sPtr--, srcCopied--; - } - } else { - *dPtr = *sPtr; - } - } - break; - case TCL_TRANSLATE_AUTO: - panic("Tcl_Write: AUTO output translation mode not supported"); - default: - panic("Tcl_Write: unknown output translation mode"); - } - - /* - * The current buffer is ready for output if it is full, or if it - * contains a newline and this channel is line-buffered, or if it - * contains any output and this channel is unbuffered. - */ - - outBufPtr->nextAdded += destCopied; - if (!(chanPtr->flags & BUFFER_READY)) { - if (outBufPtr->nextAdded == outBufPtr->bufSize) { - chanPtr->flags |= BUFFER_READY; - } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) { - for (sPtr = srcPtr, i = 0, foundNewline = 0; - (i < srcCopied) && (!foundNewline); - i++, sPtr++) { - if (*sPtr == '\n') { - foundNewline = 1; - break; - } - } - if (foundNewline) { - chanPtr->flags |= BUFFER_READY; - } - } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { - chanPtr->flags |= BUFFER_READY; - } - } - - totalDestCopied += srcCopied; - srcPtr += srcCopied; - slen -= srcCopied; - - if (chanPtr->flags & BUFFER_READY) { - if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; - } - } - } /* Closes "while" */ - - return totalDestCopied; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Flush -- - * - * Flushes output data on a channel. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May flush output queued on this channel. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Flush( - Tcl_Channel chan /* The Channel to flush. */ -) -{ - int result; /* Of calling FlushChannel. */ - Channel *chanPtr; /* The actual channel. */ - - chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return TCL_ERROR; - } - - /* - * If the channel is not open for writing punt. - */ - - if (!(chanPtr->flags & TCL_WRITABLE)) { - Tcl_SetErrno(EACCES); - return TCL_ERROR; - } - - /* - * Force current output buffer to be output also. - */ - - if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && - (chanPtr->curOutPtr->nextAdded > 0)) { - chanPtr->flags |= BUFFER_READY; - } - - result = FlushChannel(NULL, chanPtr, 0); - if (result != 0) { - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * DiscardInputQueued -- - * - * Discards any input read from the channel but not yet consumed - * by Tcl reading commands. - * - * Results: - * None. - * - * Side effects: - * May discard input from the channel. If discardLastBuffer is zero, - * leaves one buffer in place for back-filling. - * - *---------------------------------------------------------------------- - */ - -static void -DiscardInputQueued( - Channel *chanPtr, /* Channel on which to discard - * the queued input. */ - int discardSavedBuffers /* If non-zero, discard all buffers including - * last one. */ -) -{ - ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */ - - bufPtr = chanPtr->inQueueHead; - chanPtr->inQueueHead = (ChannelBuffer *) NULL; - chanPtr->inQueueTail = (ChannelBuffer *) NULL; - for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) { - nxtPtr = bufPtr->nextPtr; - RecycleBuffer(chanPtr, bufPtr, discardSavedBuffers); - } - - /* - * If discardSavedBuffers is nonzero, must also discard any previously - * saved buffer in the saveInBufPtr field. - */ - - if (discardSavedBuffers) { - if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { - ckfree((char *) chanPtr->saveInBufPtr); - chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * GetInput -- - * - * Reads input data from a device or file into an input buffer. - * - * Results: - * A Posix error code or 0. - * - * Side effects: - * Reads from the underlying device. - * - *---------------------------------------------------------------------- - */ - -static int -GetInput( - Channel *chanPtr /* Channel to read input from. */ -) -{ - int toRead; /* How much to read? */ - int result; /* Of calling driver. */ - int nread; /* How much was read from channel? */ - ChannelBuffer *bufPtr; /* New buffer to add to input queue. */ - - /* - * See if we can fill an existing buffer. If we can, read only - * as much as will fit in it. Otherwise allocate a new buffer, - * add it to the input queue and attempt to fill it to the max. - */ - - if ((chanPtr->inQueueTail != (ChannelBuffer *) NULL) && - (chanPtr->inQueueTail->nextAdded < chanPtr->inQueueTail->bufSize)) { - bufPtr = chanPtr->inQueueTail; - toRead = bufPtr->bufSize - bufPtr->nextAdded; - } else { - if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { - bufPtr = chanPtr->saveInBufPtr; - chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; - } else { - bufPtr = (ChannelBuffer *) ckalloc( - ((unsigned) CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); - bufPtr->bufSize = chanPtr->bufSize; - } - bufPtr->nextRemoved = 0; - bufPtr->nextAdded = 0; - toRead = bufPtr->bufSize; - if (chanPtr->inQueueTail == (ChannelBuffer *) NULL) { - chanPtr->inQueueHead = bufPtr; - } else { - chanPtr->inQueueTail->nextPtr = bufPtr; - } - chanPtr->inQueueTail = bufPtr; - bufPtr->nextPtr = (ChannelBuffer *) NULL; - } - - while (1) { - - /* - * If EOF is set, we should avoid calling the driver because on some - * platforms it is impossible to read from a device after EOF. - */ - - if (chanPtr->flags & CHANNEL_EOF) { - break; - } - nread = (chanPtr->typePtr->inputProc) (chanPtr->instanceData, - chanPtr->inFile, bufPtr->buf + bufPtr->nextAdded, - toRead, &result); - if (nread == 0) { - chanPtr->flags |= CHANNEL_EOF; - break; - } else if (nread < 0) { - if ((result == EWOULDBLOCK) || (result == EAGAIN)) { - chanPtr->flags |= CHANNEL_BLOCKED; - result = EAGAIN; - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - Tcl_SetErrno(result); - return result; - } else { - - /* - * If the device driver did not emulate blocking behavior - * then we have to do it here. - */ - - TclWaitForFile(chanPtr->inFile, TCL_READABLE, -1); - } - } else { - Tcl_SetErrno(result); - return result; - } - } else { - bufPtr->nextAdded += nread; - - /* - * If we get a short read, signal up that we may be BLOCKED. We - * should avoid calling the driver because on some platforms we - * will block in the low level reading code even though the - * channel is set into nonblocking mode. - */ - - if (nread < toRead) { - chanPtr->flags |= CHANNEL_BLOCKED; - } - break; - } - } - - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * CopyAndTranslateBuffer -- - * - * Copy at most one buffer of input to the result space, doing - * eol translations according to mode in effect currently. - * - * Results: - * Number of characters (as opposed to bytes) copied. May return - * zero if no input is available to be translated. - * - * Side effects: - * Consumes buffered input. May deallocate one buffer. - * - *---------------------------------------------------------------------- - */ - -static int -CopyAndTranslateBuffer( - Channel *chanPtr, /* The channel from which to read input. */ - char *result, /* Where to store the copied input. */ - int space /* How many bytes are available in result - * to store the copied input? */ -) -{ - int bytesInBuffer; /* How many bytes are available to be - * copied in the current input buffer? */ - int copied; /* How many characters were already copied - * into the destination space? */ - ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ - char curByte; /* The byte we are currently translating. */ - int i; /* Iterates over the copied input looking - * for the input eofChar. */ - - /* - * If there is no input at all, return zero. The invariant is that either - * there is no buffer in the queue, or if the first buffer is empty, it - * is also the last buffer (and thus there is no input in the queue). - * Note also that if the buffer is empty, we leave it in the queue. - */ - - if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { - return 0; - } - bufPtr = chanPtr->inQueueHead; - bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - copied = 0; - switch (chanPtr->inputTranslation) { - case TCL_TRANSLATE_LF: - - if (space == 0) { - return 0; - } - - /* - * Copy the current chunk into the result buffer. - */ - - memcpy((VOID *) result, - (VOID *)(bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - break; - - case TCL_TRANSLATE_CR: - - if (space == 0) { - return 0; - } - - /* - * Copy the current chunk into the result buffer, then - * replace all \r with \n. - */ - - memcpy((VOID *) result, - (VOID *)(bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - for (copied = 0; copied < space; copied++) { - if (result[copied] == '\r') { - result[copied] = '\n'; - } - } - break; - - case TCL_TRANSLATE_CRLF: - - /* - * If there is a held-back "\r" at EOF, produce it now. - */ - - if (space == 0) { - if ((chanPtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == - (INPUT_SAW_CR | CHANNEL_EOF)) { - result[0] = '\r'; - chanPtr->flags &= (~(INPUT_SAW_CR)); - return 1; - } - return 0; - } - - /* - * Copy the current chunk and replace "\r\n" with "\n" - * (but not standalone "\r"!). - */ - - for (copied = 0; - (copied < space) && - (bufPtr->nextRemoved < bufPtr->nextAdded); - copied++) { - curByte = bufPtr->buf[bufPtr->nextRemoved]; - bufPtr->nextRemoved++; - if (curByte == '\r') { - if (chanPtr->flags & INPUT_SAW_CR) { - result[copied] = '\r'; - } else { - chanPtr->flags |= INPUT_SAW_CR; - copied--; - } - } else if (curByte == '\n') { - chanPtr->flags &= (~(INPUT_SAW_CR)); - result[copied] = '\n'; - } else { - if (chanPtr->flags & INPUT_SAW_CR) { - chanPtr->flags &= (~(INPUT_SAW_CR)); - result[copied] = '\r'; - copied++; - } - result[copied] = curByte; - } - } - break; - - case TCL_TRANSLATE_AUTO: - - if (space == 0) { - return 0; - } - - /* - * Loop over the current buffer, converting "\r" and "\r\n" - * to "\n". - */ - - for (copied = 0; - (copied < space) && - (bufPtr->nextRemoved < bufPtr->nextAdded); ) { - curByte = bufPtr->buf[bufPtr->nextRemoved]; - bufPtr->nextRemoved++; - if (curByte == '\r') { - result[copied] = '\n'; - copied++; - if (bufPtr->nextRemoved < bufPtr->nextAdded) { - if (bufPtr->buf[bufPtr->nextRemoved] == '\n') { - bufPtr->nextRemoved++; - } - chanPtr->flags &= (~(INPUT_SAW_CR)); - } else { - chanPtr->flags |= INPUT_SAW_CR; - } - } else { - if (curByte == '\n') { - if (!(chanPtr->flags & INPUT_SAW_CR)) { - result[copied] = '\n'; - copied++; - } - } else { - result[copied] = curByte; - copied++; - } - chanPtr->flags &= (~(INPUT_SAW_CR)); - } - } - break; - - default: - panic("unknown eol translation mode"); - } - - /* - * If an in-stream EOF character is set for this channel,, check that - * the input we copied so far does not contain the EOF char. If it does, - * copy only up to and excluding that character. - */ - - if (chanPtr->inEofChar != 0) { - for (i = 0; i < copied; i++) { - if (result[i] == (char) chanPtr->inEofChar) { - break; - } - } - if (i < copied) { - - /* - * Set sticky EOF so that no further input is presented - * to the caller. - */ - - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - - /* - * Reset the start of valid data in the input buffer to the - * position of the eofChar, so that subsequent reads will - * encounter it immediately. First we set it to the position - * of the last byte consumed if all result bytes were the - * product of one input byte; since it is possible that "\r\n" - * contracted to "\n" in the result, we have to search back - * from that position until we find the eofChar, because it - * is possible that its actual position in the buffer is n - * bytes further back (n is the number of "\r\n" sequences - * that were contracted to "\n" in the result). - */ - - bufPtr->nextRemoved -= (copied - i); - while ((bufPtr->nextRemoved > 0) && - (bufPtr->buf[bufPtr->nextRemoved] != - (char) chanPtr->inEofChar)) { - bufPtr->nextRemoved--; - } - copied = i; - } - } - - /* - * If the current buffer is empty recycle it. - */ - - if (bufPtr->nextRemoved == bufPtr->nextAdded) { - chanPtr->inQueueHead = bufPtr->nextPtr; - if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { - chanPtr->inQueueTail = (ChannelBuffer *) NULL; - } - RecycleBuffer(chanPtr, bufPtr, 0); - } - - /* - * Return the number of characters copied into the result buffer. - * This may be different from the number of bytes consumed, because - * of EOL translations. - */ - - return copied; -} - -/* - *---------------------------------------------------------------------- - * - * ScanBufferForEOL -- - * - * Scans one buffer for EOL according to the specified EOL - * translation mode. If it sees the input eofChar for the channel - * it stops also. - * - * Results: - * TRUE if EOL is found, FALSE otherwise. Also sets output parameter - * bytesToEOLPtr to the number of bytes so far to EOL, and crSeenPtr - * to whether a "\r" was seen. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ScanBufferForEOL( - Channel *chanPtr, - ChannelBuffer *bufPtr, /* Buffer to scan for EOL. */ - Tcl_EolTranslation translation, /* Translation mode to use. */ - int eofChar, /* EOF char to look for. */ - int *bytesToEOLPtr, /* Running counter. */ - int *crSeenPtr /* Has "\r" been seen? */ -) -{ - char *rPtr; /* Iterates over input string. */ - char *sPtr; /* Where to stop search? */ - int EOLFound; - int bytesToEOL; - - for (EOLFound = 0, rPtr = bufPtr->buf + bufPtr->nextRemoved, - sPtr = bufPtr->buf + bufPtr->nextAdded, - bytesToEOL = *bytesToEOLPtr; - (!EOLFound) && (rPtr < sPtr); - rPtr++) { - switch (translation) { - case TCL_TRANSLATE_AUTO: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else if (*rPtr == '\n') { - - /* - * CopyAndTranslateBuffer wants to know the length - * of the result, not the input. The input is one - * larger because "\r\n" shrinks to "\n". - */ - - if (!(*crSeenPtr)) { - bytesToEOL++; - EOLFound = 1; - } else { - - /* - * This is a lf at the begining of a buffer - * where the previous buffer ended in a cr. - * Consume this lf because we've already emitted - * the newline for this crlf sequence. ALSO, if - * bytesToEOL is 0 (which means that we are at the - * first character of the scan), unset the - * INPUT_SAW_CR flag in the channel, because we - * already handled it; leaving it set would cause - * CopyAndTranslateBuffer to potentially consume - * another lf if one follows the current byte. - */ - - bufPtr->nextRemoved++; - *crSeenPtr = 0; - chanPtr->flags &= (~(INPUT_SAW_CR)); - } - } else if (*rPtr == '\r') { - bytesToEOL++; - EOLFound = 1; - } else { - *crSeenPtr = 0; - bytesToEOL++; - } - break; - case TCL_TRANSLATE_LF: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else { - if (*rPtr == '\n') { - EOLFound = 1; - } - bytesToEOL++; - } - break; - case TCL_TRANSLATE_CR: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else { - if (*rPtr == '\r') { - EOLFound = 1; - } - bytesToEOL++; - } - break; - case TCL_TRANSLATE_CRLF: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else if (*rPtr == '\n') { - - /* - * CopyAndTranslateBuffer wants to know the length - * of the result, not the input. The input is one - * larger because crlf shrinks to lf. - */ - - if (*crSeenPtr) { - EOLFound = 1; - } else { - bytesToEOL++; - } - } else { - if (*rPtr == '\r') { - *crSeenPtr = 1; - } else { - *crSeenPtr = 0; - } - bytesToEOL++; - } - break; - default: - panic("unknown eol translation mode"); - } - } - - *bytesToEOLPtr = bytesToEOL; - return EOLFound; -} - -/* - *---------------------------------------------------------------------- - * - * ScanInputForEOL -- - * - * Scans queued input for chanPtr for an end of line (according to the - * current EOL translation mode) and returns the number of bytes - * upto and including the end of line, or -1 if none was found. - * - * Results: - * Count of bytes upto and including the end of line if one is present - * or -1 if none was found. Also returns in an output parameter the - * number of bytes queued if no end of line was found. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ScanInputForEOL( - Channel *chanPtr, /* Channel for which to scan queued - * input for end of line. */ - int *bytesQueuedPtr /* Where to store the number of bytes - * currently queued if no end of line - * was found. */ -) -{ - ChannelBuffer *bufPtr; /* Iterates over queued buffers. */ - int bytesToEOL; /* How many bytes to end of line? */ - int EOLFound; /* Did we find an end of line? */ - int crSeen; /* Did we see a "\r" in CRLF mode? */ - - *bytesQueuedPtr = 0; - bytesToEOL = 0; - EOLFound = 0; - for (bufPtr = chanPtr->inQueueHead, - crSeen = (chanPtr->flags & INPUT_SAW_CR) ? 1 : 0; - (!EOLFound) && (bufPtr != (ChannelBuffer *) NULL); - bufPtr = bufPtr->nextPtr) { - EOLFound = ScanBufferForEOL(chanPtr, bufPtr, chanPtr->inputTranslation, - chanPtr->inEofChar, &bytesToEOL, &crSeen); - } - - if (EOLFound == 0) { - *bytesQueuedPtr = bytesToEOL; - return -1; - } - return bytesToEOL; -} - -/* - *---------------------------------------------------------------------- - * - * GetEOL -- - * - * Accumulate input into the channel input buffer queue until an - * end of line has been seen. - * - * Results: - * Number of bytes buffered or -1 on failure. - * - * Side effects: - * Consumes input from the channel. - * - *---------------------------------------------------------------------- - */ - -static int -GetEOL( - Channel *chanPtr /* Channel to queue input on. */ -) -{ - int result; /* Of getting another buffer from the - * channel. */ - int bytesToEOL; /* How many bytes in buffer up to and - * including the end of line? */ - int bytesQueued; /* How many bytes are queued currently - * in the input chain of the channel? */ - - while (1) { - bytesToEOL = ScanInputForEOL(chanPtr, &bytesQueued); - if (bytesToEOL > 0) { - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - return bytesToEOL; - } - if (chanPtr->flags & CHANNEL_EOF) { - /* - * Boundary case where cr was at the end of the previous buffer - * and this buffer just has a newline. At EOF our caller wants - * to see -1 for the line length. - */ - return (bytesQueued == 0) ? -1 : bytesQueued ; - } - if (chanPtr->flags & CHANNEL_BLOCKED) { - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - return -1; - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - } - result = GetInput(chanPtr); - if (result != 0) { - if (result == EAGAIN) { - chanPtr->flags |= CHANNEL_BLOCKED; - } - return -1; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Read -- - * - * Reads a given number of characters from a channel. - * - * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. - * - * Side effects: - * May cause input to be buffered. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Read( - Tcl_Channel chan, /* The channel from which to read. */ - char *bufPtr, /* Where to store input read. */ - int toRead /* Maximum number of characters to read. */ -) -{ - Channel *chanPtr; /* The real IO channel. */ - int copied; /* How many characters were copied into - * the result string? */ - int copiedNow; /* How many characters were copied from - * the current input buffer? */ - int result; /* Of calling GetInput. */ - - chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; - } - - /* - * Punt if the channel is not opened for reading. - */ - - if (!(chanPtr->flags & TCL_READABLE)) { - Tcl_SetErrno(EACCES); - return -1; - } - - /* - * If we have not encountered a sticky EOF, clear the EOF bit. Either - * way clear the BLOCKED bit. We want to discover these anew during - * each operation. - */ - - if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { - chanPtr->flags &= (~(CHANNEL_EOF)); - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - - for (copied = 0; copied < toRead; copied += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied, - toRead - copied); - if (copiedNow == 0) { - if (chanPtr->flags & CHANNEL_EOF) { - return copied; - } - if (chanPtr->flags & CHANNEL_BLOCKED) { - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - return copied; - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - } - result = GetInput(chanPtr); - if (result != 0) { - if (result == EAGAIN) { - return copied; - } - return -1; - } - } - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - return copied; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Gets -- - * - * Reads a complete line of input from the channel. - * - * Results: - * Length of line read or -1 if error, EOF or blocked. If -1, use - * Tcl_GetErrno() to retrieve the POSIX error code for the - * error or condition that occurred. - * - * Side effects: - * May flush output on the channel. May cause input to be - * consumed from the channel. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Gets( - Tcl_Channel chan, /* Channel from which to read. */ - Tcl_DString *lineRead /* The characters of the line read - * (excluding the terminating newline if - * present) will be appended to this - * DString. The caller must have initialized - * it and is responsible for managing the - * storage. */ -) -{ - Channel *chanPtr; /* The channel to read from. */ - char *buf; /* Points into DString where data - * will be stored. */ - int offset; /* Offset from start of DString at - * which to append the line just read. */ - int copiedTotal; /* Accumulates total length of input copied. */ - int copiedNow; /* How many bytes were copied from the - * current input buffer? */ - int lineLen; /* Length of line read, including the - * translated newline. If this is zero - * and neither EOF nor BLOCKED is set, - * the current line is empty. */ - - chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; - } - - /* - * Punt if the channel is not opened for reading. - */ - - if (!(chanPtr->flags & TCL_READABLE)) { - Tcl_SetErrno(EACCES); - return -1; - } - - /* - * If we have not encountered a sticky EOF, clear the EOF bit - * (sticky EOF is set if we have seen the input eofChar, to prevent - * reading beyond the eofChar). Also, always clear the BLOCKED bit. - * We want to discover these conditions anew in each operation. - */ - - if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { - chanPtr->flags &= (~(CHANNEL_EOF)); - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - lineLen = GetEOL(chanPtr); - if (lineLen < 0) { - return -1; - } - if (lineLen == 0) { - if (chanPtr->flags & (CHANNEL_EOF | CHANNEL_BLOCKED)) { - return -1; - } - return 0; - } - offset = Tcl_DStringLength(lineRead); - Tcl_DStringSetLength(lineRead, lineLen + offset); - buf = Tcl_DStringValue(lineRead) + offset; - - for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, - lineLen - copiedTotal); - } - if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { - copiedTotal--; - } - Tcl_DStringSetLength(lineRead, copiedTotal + offset); - return copiedTotal; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Seek -- - * - * Implements seeking on Tcl Channels. This is a public function - * so that other C facilities may be implemented on top of it. - * - * Results: - * The new access point or -1 on error. If error, use Tcl_GetErrno() - * to retrieve the POSIX error code for the error that occurred. - * - * Side effects: - * May flush output on the channel. May discard queued input. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Seek( - Tcl_Channel chan, /* The channel on which to seek. */ - int offset, /* Offset to seek to. */ - int mode /* Relative to which location to seek? */ -) -{ - Channel *chanPtr; /* The real IO channel. */ - ChannelBuffer *bufPtr; /* Iterates over queued input - * and output buffers. */ - int inputBuffered, outputBuffered; - int result; /* Of device driver operations. */ - int curPos; /* Position on the device. */ - int wasAsync; /* Was the channel nonblocking before the - * seek operation? If so, must restore to - * nonblocking mode after the seek. */ - - chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; - } - - /* - * Disallow seek on channels that are open for neither writing nor - * reading (e.g. socket server channels). - */ - - if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { - Tcl_SetErrno(EACCES); - return -1; - } - - /* - * Disallow seek on channels whose type does not have a seek procedure - * defined. This means that the channel does not support seeking. - */ - - if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { - Tcl_SetErrno(EINVAL); - return -1; - } - - /* - * Compute how much input and output is buffered. If both input and - * output is buffered, cannot compute the current position. - */ - - for (bufPtr = chanPtr->inQueueHead, inputBuffered = 0; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - for (bufPtr = chanPtr->outQueueHead, outputBuffered = 0; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && - (chanPtr->curOutPtr->nextAdded > chanPtr->curOutPtr->nextRemoved)) { - chanPtr->flags |= BUFFER_READY; - outputBuffered += - (chanPtr->curOutPtr->nextAdded - chanPtr->curOutPtr->nextRemoved); - } - if ((inputBuffered != 0) && (outputBuffered != 0)) { - Tcl_SetErrno(EFAULT); - return -1; - } - - /* - * If we are seeking relative to the current position, compute the - * corrected offset taking into account the amount of unread input. - */ - - if (mode == SEEK_CUR) { - offset -= inputBuffered; - } - - /* - * Discard any queued input - this input should not be read after - * the seek. - */ - - DiscardInputQueued(chanPtr, 0); - - /* - * Reset EOF and BLOCKED flags. We invalidate them by moving the - * access point. Also clear CR related flags. - */ - - chanPtr->flags &= - (~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR)); - - /* - * If the channel is in asynchronous output mode, switch it back - * to synchronous mode and cancel any async flush that may be - * scheduled. After the flush, the channel will be put back into - * asynchronous output mode. - */ - - wasAsync = 0; - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - wasAsync = 1; - result = 0; - if (chanPtr->typePtr->blockModeProc != NULL) { - result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, - chanPtr->inFile, chanPtr->outFile, TCL_MODE_BLOCKING); - } - if (result != 0) { - Tcl_SetErrno(result); - return -1; - } - chanPtr->flags &= (~(CHANNEL_NONBLOCKING)); - if (chanPtr->flags & BG_FLUSH_SCHEDULED) { - Tcl_DeleteFileHandler(chanPtr->outFile); - chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); - } - } - - /* - * If the flush fails we cannot recover the original position. In - * that case the seek is not attempted because we do not know where - * the access position is - instead we return the error. FlushChannel - * has already called Tcl_SetErrno() to report the error upwards. - * If the flush succeeds we do the seek also. - */ - - if (FlushChannel(NULL, chanPtr, 0) != 0) { - curPos = -1; - } else { - - /* - * Now seek to the new position in the channel as requested by the - * caller. - */ - - curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, - chanPtr->inFile, chanPtr->outFile, (long) offset, - mode, &result); - if (curPos == -1) { - Tcl_SetErrno(result); - } - } - - /* - * Restore to nonblocking mode if that was the previous behavior. - * - * NOTE: Even if there was an async flush active we do not restore - * it now because we already flushed all the queued output, above. - */ - - if (wasAsync) { - chanPtr->flags |= CHANNEL_NONBLOCKING; - result = 0; - if (chanPtr->typePtr->blockModeProc != NULL) { - result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, - chanPtr->inFile, chanPtr->outFile, TCL_MODE_NONBLOCKING); - } - if (result != 0) { - Tcl_SetErrno(result); - return -1; - } - } - - return curPos; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Tell -- - * - * Returns the position of the next character to be read/written on - * this channel. - * - * Results: - * A nonnegative integer on success, -1 on failure. If failed, - * use Tcl_GetErrno() to retrieve the POSIX error code for the - * error that occurred. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Tell( - Tcl_Channel chan /* The channel to return pos for. */ -) -{ - Channel *chanPtr; /* The actual channel to tell on. */ - ChannelBuffer *bufPtr; /* Iterates over queued input - * and output buffers. */ - int inputBuffered, outputBuffered; - int result; /* Of calling device driver. */ - int curPos; /* Position on device. */ - - chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; - } - - /* - * Disallow tell on channels that are open for neither - * writing nor reading (e.g. socket server channels). - */ - - if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { - Tcl_SetErrno(EACCES); - return -1; - } - - /* - * Disallow tell on channels whose type does not have a seek procedure - * defined. This means that the channel does not support seeking. - */ - - if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { - Tcl_SetErrno(EINVAL); - return -1; - } - - /* - * Compute how much input and output is buffered. If both input and - * output is buffered, cannot compute the current position. - */ - - for (bufPtr = chanPtr->inQueueHead, inputBuffered = 0; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - for (bufPtr = chanPtr->outQueueHead, outputBuffered = 0; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { - outputBuffered += - (chanPtr->curOutPtr->nextAdded - chanPtr->curOutPtr->nextRemoved); - } - if ((inputBuffered != 0) && (outputBuffered != 0)) { - Tcl_SetErrno(EFAULT); - return -1; - } - - /* - * Get the current position in the device and compute the position - * where the next character will be read or written. - */ - - curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, - chanPtr->inFile, chanPtr->outFile, (long) 0, SEEK_CUR, &result); - if (curPos == -1) { - Tcl_SetErrno(result); - return -1; - } - if (inputBuffered != 0) { - return (curPos - inputBuffered); - } - return (curPos + outputBuffered); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Eof -- - * - * Returns 1 if the channel is at EOF, 0 otherwise. - * - * Results: - * 1 or 0, always. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Eof( - Tcl_Channel chan /* Does this channel have EOF? */ -) -{ - Channel *chanPtr; /* The real channel structure. */ - - chanPtr = (Channel *) chan; - return ((chanPtr->flags & CHANNEL_STICKY_EOF) || - ((chanPtr->flags & CHANNEL_EOF) && (Tcl_InputBuffered(chan) == 0))) - ? 1 : 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InputBlocked -- - * - * Returns 1 if input is blocked on this channel, 0 otherwise. - * - * Results: - * 0 or 1, always. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_InputBlocked( - Tcl_Channel chan /* Is this channel blocked? */ -) -{ - Channel *chanPtr; /* The real channel structure. */ - - chanPtr = (Channel *) chan; - return (chanPtr->flags & CHANNEL_BLOCKED) ? 1 : 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InputBuffered -- - * - * Returns the number of bytes of input currently buffered in the - * internal buffer of a channel. - * - * Results: - * The number of input bytes buffered, or zero if the channel is not - * open for reading. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_InputBuffered( - Tcl_Channel chan /* The channel to query. */ -) -{ - Channel *chanPtr; - int bytesBuffered; - ChannelBuffer *bufPtr; - - chanPtr = (Channel *) chan; - for (bytesBuffered = 0, bufPtr = chanPtr->inQueueHead; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - bytesBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - return bytesBuffered; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetChannelBufferSize -- - * - * Sets the size of buffers to allocate to store input or output - * in the channel. The size must be between 10 bytes and 1 MByte. - * - * Results: - * None. - * - * Side effects: - * Sets the size of buffers subsequently allocated for this channel. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetChannelBufferSize( - Tcl_Channel chan, /* The channel whose buffer size - * to set. */ - int sz /* The size to set. */ -) -{ - Channel *chanPtr; - - if (sz < 10) { - sz = CHANNELBUFFER_DEFAULT_SIZE; - } - - /* - * Allow only buffers that are smaller than one megabyte. - */ - - if (sz > (1024 * 1024)) { - sz = CHANNELBUFFER_DEFAULT_SIZE; - } - - chanPtr = (Channel *) chan; - chanPtr->bufSize = sz; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetChannelBufferSize -- - * - * Retrieves the size of buffers to allocate for this channel. - * - * Results: - * The size. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetChannelBufferSize( - Tcl_Channel chan /* The channel for which to find the - * buffer size. */ -) -{ - Channel *chanPtr; - - chanPtr = (Channel *) chan; - return chanPtr->bufSize; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetChannelOption -- - * - * Gets a mode associated with an IO channel. If the optionName arg - * is non NULL, retrieves the value of that option. If the optionName - * arg is NULL, retrieves a list of alternating option names and - * values for the given channel. - * - * Results: - * A standard Tcl result. Also sets the supplied DString to the - * string value of the option(s) returned. - * - * Side effects: - * The string returned by this function is in static storage and - * may be reused at any time subsequent to the call. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetChannelOption( - Tcl_Channel chan, /* Channel on which to get option. */ - char *optionName, /* Option to get. */ - Tcl_DString *dsPtr /* Where to store value(s). */ -) -{ - Channel *chanPtr; /* The real IO channel. */ - size_t len; /* Length of optionName string. */ - - chanPtr = (Channel *) chan; - - /* - * If the optionName is NULL it means that we want a list of all - * options and values. - */ - - if (optionName == (char *) NULL) { - len = 0; - } else { - len = strlen(optionName); - } - - if ((len == 0) || ((len > 2) && (optionName[1] == 'b') && - (strncmp(optionName, "-blocking", len) == 0))) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-blocking"); - } - Tcl_DStringAppendElement(dsPtr, - (chanPtr->flags & CHANNEL_NONBLOCKING) ? "0" : "1"); - if (len > 0) { - return TCL_OK; - } - } - if ((len == 0) || ((len > 7) && (optionName[1] == 'b') && - (strncmp(optionName, "-buffering", len) == 0))) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-buffering"); - } - if (chanPtr->flags & CHANNEL_LINEBUFFERED) { - Tcl_DStringAppendElement(dsPtr, "line"); - } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { - Tcl_DStringAppendElement(dsPtr, "none"); - } else { - Tcl_DStringAppendElement(dsPtr, "full"); - } - if (len > 0) { - return TCL_OK; - } - } - if ((len == 0) || ((len > 7) && (optionName[1] == 'b') && - (strncmp(optionName, "-buffersize", len) == 0))) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-buffersize"); - } - sprintf(optionVal, "%d", chanPtr->bufSize); - Tcl_DStringAppendElement(dsPtr, optionVal); - if (len > 0) { - return TCL_OK; - } - } - if ((len == 0) || - ((len > 1) && (optionName[1] == 'e') && - (strncmp(optionName, "-eofchar", len) == 0))) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-eofchar"); - } - if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) { - Tcl_DStringStartSublist(dsPtr); - } - if (chanPtr->flags & TCL_READABLE) { - if (chanPtr->inEofChar == 0) { - Tcl_DStringAppendElement(dsPtr, ""); - } else { - char buf[4]; - - sprintf(buf, "%c", chanPtr->inEofChar); - Tcl_DStringAppendElement(dsPtr, buf); - } - } - if (chanPtr->flags & TCL_WRITABLE) { - if (chanPtr->outEofChar == 0) { - Tcl_DStringAppendElement(dsPtr, ""); - } else { - char buf[4]; - - sprintf(buf, "%c", chanPtr->outEofChar); - Tcl_DStringAppendElement(dsPtr, buf); - } - } - if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) { - Tcl_DStringEndSublist(dsPtr); - } - if (len > 0) { - return TCL_OK; - } - } - if ((len == 0) || - ((len > 1) && (optionName[1] == 't') && - (strncmp(optionName, "-translation", len) == 0))) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-translation"); - } - if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) { - Tcl_DStringStartSublist(dsPtr); - } - if (chanPtr->flags & TCL_READABLE) { - if (chanPtr->inputTranslation == TCL_TRANSLATE_AUTO) { - Tcl_DStringAppendElement(dsPtr, "auto"); - } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CR) { - Tcl_DStringAppendElement(dsPtr, "cr"); - } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CRLF) { - Tcl_DStringAppendElement(dsPtr, "crlf"); - } else { - Tcl_DStringAppendElement(dsPtr, "lf"); - } - } - if (chanPtr->flags & TCL_WRITABLE) { - if (chanPtr->outputTranslation == TCL_TRANSLATE_AUTO) { - Tcl_DStringAppendElement(dsPtr, "auto"); - } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CR) { - Tcl_DStringAppendElement(dsPtr, "cr"); - } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CRLF) { - Tcl_DStringAppendElement(dsPtr, "crlf"); - } else { - Tcl_DStringAppendElement(dsPtr, "lf"); - } - } - if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) { - Tcl_DStringEndSublist(dsPtr); - } - if (len > 0) { - return TCL_OK; - } - } - if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) { - return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData, - optionName, dsPtr); - } - if (len == 0) { - return TCL_OK; - } - Tcl_SetErrno(EINVAL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetChannelOption -- - * - * Sets an option on a channel. - * - * Results: - * A standard Tcl result. Also sets interp->result on error if - * interp is not NULL. - * - * Side effects: - * May modify an option on a device. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetChannelOption( - Tcl_Interp *interp, /* For error reporting - can be NULL. */ - Tcl_Channel chan, /* Channel on which to set mode. */ - char *optionName, /* Which option to set? */ - char *newValue /* New value for option. */ -) -{ - int result; /* Result of channel type operation. */ - int newMode; /* New (numeric) mode to sert. */ - Channel *chanPtr; /* The real IO channel. */ - size_t len; /* Length of optionName string. */ - int argc; - char **argv; - - chanPtr = (Channel *) chan; - - len = strlen(optionName); - - if ((len > 2) && (optionName[1] == 'b') && - (strncmp(optionName, "-blocking", len) == 0)) { - if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { - return TCL_ERROR; - } - if (newMode) { - newMode = TCL_MODE_BLOCKING; - } else { - newMode = TCL_MODE_NONBLOCKING; - } - result = 0; - if (chanPtr->typePtr->blockModeProc != NULL) { - result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, - chanPtr->inFile, chanPtr->outFile, newMode); - } - if (result != 0) { - Tcl_SetErrno(result); - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "error setting blocking mode: ", - Tcl_PosixError(interp), (char *) NULL); - } - return TCL_ERROR; - } - if (newMode == TCL_MODE_BLOCKING) { - chanPtr->flags &= (~(CHANNEL_NONBLOCKING)); - if (chanPtr->outFile != (Tcl_File) NULL) { - Tcl_DeleteFileHandler(chanPtr->outFile); - chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); - } - } else { - chanPtr->flags |= CHANNEL_NONBLOCKING; - } - return TCL_OK; - } - - if ((len > 7) && (optionName[1] == 'b') && - (strncmp(optionName, "-buffering", len) == 0)) { - len = strlen(newValue); - if ((newValue[0] == 'f') && (strncmp(newValue, "full", len) == 0)) { - chanPtr->flags &= - (~(CHANNEL_UNBUFFERED|CHANNEL_LINEBUFFERED)); - } else if ((newValue[0] == 'l') && - (strncmp(newValue, "line", len) == 0)) { - chanPtr->flags &= (~(CHANNEL_UNBUFFERED)); - chanPtr->flags |= CHANNEL_LINEBUFFERED; - } else if ((newValue[0] == 'n') && - (strncmp(newValue, "none", len) == 0)) { - chanPtr->flags &= (~(CHANNEL_LINEBUFFERED)); - chanPtr->flags |= CHANNEL_UNBUFFERED; - } else { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "bad value for -buffering: ", - "must be one of full, line, or none", - (char *) NULL); - return TCL_ERROR; - } - } - return TCL_OK; - } - - if ((len > 7) && (optionName[1] == 'b') && - (strncmp(optionName, "-buffersize", len) == 0)) { - chanPtr->bufSize = atoi(newValue); - if ((chanPtr->bufSize < 10) || (chanPtr->bufSize > (1024 * 1024))) { - chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; - } - return TCL_OK; - } - - if ((len > 1) && (optionName[1] == 'e') && - (strncmp(optionName, "-eofchar", len) == 0)) { - if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { - return TCL_ERROR; - } - if (argc == 0) { - chanPtr->inEofChar = 0; - chanPtr->outEofChar = 0; - } else if (argc == 1) { - if (chanPtr->flags & TCL_WRITABLE) { - chanPtr->outEofChar = (int) argv[0][0]; - } - if (chanPtr->flags & TCL_READABLE) { - chanPtr->inEofChar = (int) argv[0][0]; - } - } else if (argc != 2) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "bad value for -eofchar: should be a list of one or", - " two elements", (char *) NULL); - } - ckfree((char *) argv); - return TCL_ERROR; - } else { - if (chanPtr->flags & TCL_READABLE) { - chanPtr->inEofChar = (int) argv[0][0]; - } - if (chanPtr->flags & TCL_WRITABLE) { - chanPtr->outEofChar = (int) argv[1][0]; - } - } - if (argv != (char **) NULL) { - ckfree((char *) argv); - } - return TCL_OK; - } - - if ((len > 1) && (optionName[1] == 't') && - (strncmp(optionName, "-translation", len) == 0)) { - if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { - return TCL_ERROR; - } - if (argc == 1) { - if (chanPtr->flags & TCL_READABLE) { - chanPtr->flags &= (~(INPUT_SAW_CR)); - if (strcmp(argv[0], "auto") == 0) { - chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; - } else if (strcmp(argv[0], "binary") == 0) { - chanPtr->inEofChar = 0; - chanPtr->inputTranslation = TCL_TRANSLATE_LF; - } else if (strcmp(argv[0], "lf") == 0) { - chanPtr->inputTranslation = TCL_TRANSLATE_LF; - } else if (strcmp(argv[0], "cr") == 0) { - chanPtr->inputTranslation = TCL_TRANSLATE_CR; - } else if (strcmp(argv[0], "crlf") == 0) { - chanPtr->inputTranslation = TCL_TRANSLATE_CRLF; - } else if (strcmp(argv[0], "platform") == 0) { - chanPtr->inputTranslation = TCL_PLATFORM_TRANSLATION; - } else { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "bad value for -translation: ", - "must be one of auto, binary, cr, lf, crlf,", - " or platform", (char *) NULL); - } - ckfree((char *) argv); - return TCL_ERROR; - } - } - if (chanPtr->flags & TCL_WRITABLE) { - if (strcmp(argv[0], "auto") == 0) { - /* - * This is a hack to get TCP sockets to produce output - * in CRLF mode if they are being set into AUTO mode. - * A better solution for achieving this effect will be - * coded later. - */ - - if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) { - chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; - } else { - chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; - } - } else if (strcmp(argv[0], "binary") == 0) { - chanPtr->outEofChar = 0; - chanPtr->outputTranslation = TCL_TRANSLATE_LF; - } else if (strcmp(argv[0], "lf") == 0) { - chanPtr->outputTranslation = TCL_TRANSLATE_LF; - } else if (strcmp(argv[0], "cr") == 0) { - chanPtr->outputTranslation = TCL_TRANSLATE_CR; - } else if (strcmp(argv[0], "crlf") == 0) { - chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; - } else if (strcmp(argv[0], "platform") == 0) { - chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; - } else { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "bad value for -translation: ", - "must be one of auto, binary, cr, lf, crlf,", - " or platform", (char *) NULL); - } - ckfree((char *) argv); - return TCL_ERROR; - } - } - } else if (argc != 2) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "bad value for -translation: must be a one or two", - " element list", (char *) NULL); - } - ckfree((char *) argv); - return TCL_ERROR; - } else { - if (chanPtr->flags & TCL_READABLE) { - if (argv[0][0] == '\0') { - /* Empty body. */ - } else if (strcmp(argv[0], "auto") == 0) { - chanPtr->flags &= (~(INPUT_SAW_CR)); - chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; - } else if (strcmp(argv[0], "binary") == 0) { - chanPtr->inEofChar = 0; - chanPtr->flags &= (~(INPUT_SAW_CR)); - chanPtr->inputTranslation = TCL_TRANSLATE_LF; - } else if (strcmp(argv[0], "lf") == 0) { - chanPtr->flags &= (~(INPUT_SAW_CR)); - chanPtr->inputTranslation = TCL_TRANSLATE_LF; - } else if (strcmp(argv[0], "cr") == 0) { - chanPtr->flags &= (~(INPUT_SAW_CR)); - chanPtr->inputTranslation = TCL_TRANSLATE_CR; - } else if (strcmp(argv[0], "crlf") == 0) { - chanPtr->flags &= (~(INPUT_SAW_CR)); - chanPtr->inputTranslation = TCL_TRANSLATE_CRLF; - } else if (strcmp(argv[0], "platform") == 0) { - chanPtr->flags &= (~(INPUT_SAW_CR)); - chanPtr->inputTranslation = TCL_PLATFORM_TRANSLATION; - } else { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "bad value for -translation: ", - "must be one of auto, binary, cr, lf, crlf,", - " or platform", (char *) NULL); - } - ckfree((char *) argv); - return TCL_ERROR; - } - } - if (chanPtr->flags & TCL_WRITABLE) { - if (argv[1][0] == '\0') { - /* Empty body. */ - } else if (strcmp(argv[1], "auto") == 0) { - /* - * This is a hack to get TCP sockets to produce output - * in CRLF mode if they are being set into AUTO mode. - * A better solution for achieving this effect will be - * coded later. - */ - - if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) { - chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; - } else { - chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; - } - } else if (strcmp(argv[1], "binary") == 0) { - chanPtr->outEofChar = 0; - chanPtr->outputTranslation = TCL_TRANSLATE_LF; - } else if (strcmp(argv[1], "lf") == 0) { - chanPtr->outputTranslation = TCL_TRANSLATE_LF; - } else if (strcmp(argv[1], "cr") == 0) { - chanPtr->outputTranslation = TCL_TRANSLATE_CR; - } else if (strcmp(argv[1], "crlf") == 0) { - chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; - } else if (strcmp(argv[1], "platform") == 0) { - chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; - } else { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "bad value for -translation: ", - "must be one of auto, binary, cr, lf, crlf,", - " or platform", (char *) NULL); - } - ckfree((char *) argv); - return TCL_ERROR; - } - } - } - ckfree((char *) argv); - return TCL_OK; - } - - if (chanPtr->typePtr->setOptionProc != (Tcl_DriverSetOptionProc *) NULL) { - return (chanPtr->typePtr->setOptionProc) (chanPtr->instanceData, - interp, optionName, newValue); - } - - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "bad option \"", optionName, - "\": should be -blocking, -buffering, -buffersize, ", - "-eofchar, -translation, ", - "or channel type specific option", - (char *) NULL); - } - - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * ChannelEventSourceExitProc -- - * - * This procedure is called during exit cleanup to delete the channel - * event source. It deletes the event source for channels. - * - * Results: - * None. - * - * Side effects: - * Destroys the channel event source. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -ChannelEventSourceExitProc( - ClientData clientData /* Not used. */ -) -{ - Tcl_DeleteEventSource(ChannelHandlerSetupProc, ChannelHandlerCheckProc, - (ClientData) NULL); - channelEventSourceCreated = 0; -} - -/* - *---------------------------------------------------------------------- - * - * ChannelHandlerSetupProc -- - * - * This procedure is part of the event source for channel handlers. - * It is invoked by Tcl_DoOneEvent before it waits for events. The - * job of this procedure is to provide information to Tcl_DoOneEvent - * on how to wait for events (what files to watch). - * - * Results: - * None. - * - * Side effects: - * Tells the notifier what channels to watch. - * - *---------------------------------------------------------------------- - */ - -static void -ChannelHandlerSetupProc( - ClientData clientData, /* Not used. */ - int flags /* Flags passed to Tk_DoOneEvent: - * if it doesn't include - * TCL_FILE_EVENTS then we do - * nothing. */ -) -{ - Tcl_Time dontBlock; - Channel *chanPtr, *nextChanPtr; - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - dontBlock.sec = 0; dontBlock.usec = 0; - - for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL; - chanPtr = nextChanPtr) { - nextChanPtr = chanPtr->nextChanPtr; - if (chanPtr->interestMask & TCL_READABLE) { - if ((!(chanPtr->flags & CHANNEL_BLOCKED)) && - (chanPtr->inQueueHead != (ChannelBuffer *) NULL) && - (chanPtr->inQueueHead->nextRemoved < - chanPtr->inQueueHead->nextAdded)) { - Tcl_SetMaxBlockTime(&dontBlock); - } else if (chanPtr->inFile != (Tcl_File) NULL) { - Tcl_WatchFile(chanPtr->inFile, TCL_READABLE); - } - } - if (chanPtr->interestMask & TCL_WRITABLE) { - if (chanPtr->outFile != (Tcl_File) NULL) { - Tcl_WatchFile(chanPtr->outFile, TCL_WRITABLE); - } - } - if (chanPtr->interestMask & TCL_EXCEPTION) { - if (chanPtr->inFile != (Tcl_File) NULL) { - Tcl_WatchFile(chanPtr->inFile, TCL_EXCEPTION); - } - if (chanPtr->outFile != (Tcl_File) NULL) { - Tcl_WatchFile(chanPtr->outFile, TCL_EXCEPTION); - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * ChannelHandlerCheckProc -- - * - * This procedure is the second part (of three) of the event source - * for channels. It is invoked by Tcl_DoOneEvent after the wait for - * events is over. The job of this procedure is to test each channel - * to see if it is ready now, and if so, to create events and put them - * on the Tcl event queue. - * - * Results: - * None. - * - * Side effects: - * Makes entries on the Tcl event queue for each channel that is - * ready now. - * - *---------------------------------------------------------------------- - */ - -static void -ChannelHandlerCheckProc( - ClientData clientData, /* Not used. */ - int flags /* Flags passed to Tk_DoOneEvent: - * if it doesn't include - * TCL_FILE_EVENTS then we do - * nothing. */ -) -{ - Channel *chanPtr, *nextChanPtr; - ChannelHandlerEvent *ePtr; - int readyMask; - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } - - for (chanPtr = firstChanPtr; - chanPtr != (Channel *) NULL; - chanPtr = nextChanPtr) { - nextChanPtr = chanPtr->nextChanPtr; - - readyMask = 0; - - /* - * Check for readability. - */ - - if (chanPtr->interestMask & TCL_READABLE) { - - /* - * The channel is considered ready for reading if there is input - * buffered AND the last attempt to read from the channel did not - * return EWOULDBLOCK, OR if the underlying file is ready. - * - * NOTE that the input queue may contain empty buffers, hence the - * special check to see if the first input buffer is empty. The - * invariant is that if there is an empty buffer in the queue - * there is only one buffer in the queue, hence an empty first - * buffer indicates that there is no input queued. - */ - - if ((!(chanPtr->flags & CHANNEL_BLOCKED)) && - ((chanPtr->inQueueHead != (ChannelBuffer *) NULL) && - (chanPtr->inQueueHead->nextRemoved < - chanPtr->inQueueHead->nextAdded))) { - readyMask |= TCL_READABLE; - } else if (chanPtr->inFile != (Tcl_File) NULL) { - readyMask |= - Tcl_FileReady(chanPtr->inFile, TCL_READABLE); - } - } - - /* - * Check for writability. - */ - - if (chanPtr->interestMask & TCL_WRITABLE) { - - /* - * The channel is considered ready for writing if there is no - * output buffered waiting to be written to the device, AND the - * underlying file is ready. - */ - - if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && - (chanPtr->outFile != (Tcl_File) NULL)) { - readyMask |= - Tcl_FileReady(chanPtr->outFile, TCL_WRITABLE); - } - } - - /* - * Check for exceptions. - */ - - if (chanPtr->interestMask & TCL_EXCEPTION) { - if (chanPtr->inFile != (Tcl_File) NULL) { - readyMask |= - Tcl_FileReady(chanPtr->inFile, TCL_EXCEPTION); - } - if (chanPtr->outFile != (Tcl_File) NULL) { - readyMask |= - Tcl_FileReady(chanPtr->outFile, TCL_EXCEPTION); - } - } - - /* - * If there are any events for this channel, put a notice into the - * Tcl event queue. - */ - - if (readyMask != 0) { - ePtr = (ChannelHandlerEvent *) ckalloc((unsigned) - sizeof(ChannelHandlerEvent)); - ePtr->header.proc = ChannelHandlerEventProc; - ePtr->chanPtr = chanPtr; - ePtr->readyMask = readyMask; - Tcl_QueueEvent((Tcl_Event *) ePtr, TCL_QUEUE_TAIL); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * FlushEventProc -- - * - * This routine dispatches a background flush event. - * - * Errors that occur during the write operation are stored - * inside the channel structure for future reporting by the next - * operation that uses this channel. - * - * Results: - * None. - * - * Side effects: - * Causes production of output on a channel. - * - *---------------------------------------------------------------------- - */ - -static void -FlushEventProc( - ClientData clientData, /* Channel to produce output on. */ - int mask /* Not used. */ -) -{ - (void) FlushChannel(NULL, (Channel *) clientData, 1); -} - -/* - *---------------------------------------------------------------------- - * - * ChannelHandlerEventProc -- - * - * This procedure is called by Tcl_DoOneEvent when a channel event - * reaches the front of the event queue. This procedure is responsible - * for actually handling the event by invoking the callback for the - * channel handler. - * - * Results: - * Returns 1 if the event was handled, meaning that it should be - * removed from the queue. Returns 0 if the event was not handled - * meaning that it should stay in the queue. The only time the event - * will not be handled is if the TCL_FILE_EVENTS flag bit is not - * set in the flags passed. - * - * NOTE: If the handler is deleted between the time the event is added - * to the queue and the time it reaches the head of the queue, the - * event is silently discarded (i.e. we return 1). - * - * Side effects: - * Whatever the channel handler callback procedure does. - * - *---------------------------------------------------------------------- - */ - -static int -ChannelHandlerEventProc( - Tcl_Event *evPtr, /* Event to service. */ - int flags /* Flags that indicate what events to - * handle, such as TCL_FILE_EVENTS. */ -) -{ - Channel *chanPtr; - ChannelHandler *chPtr; - ChannelHandlerEvent *ePtr; - NextChannelHandler nh; - - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } - - ePtr = (ChannelHandlerEvent *) evPtr; - chanPtr = ePtr->chanPtr; - - /* - * Add this invocation to the list of recursive invocations of - * ChannelHandlerEventProc. - */ - - nh.nextHandlerPtr = (ChannelHandler *) NULL; - nh.nestedHandlerPtr = nestedHandlerPtr; - nestedHandlerPtr = &nh; - - for (chPtr = chanPtr->chPtr; chPtr != (ChannelHandler *) NULL; ) { - - /* - * If this channel handler is interested in any of the events that - * have occurred on the channel, invoke its procedure. - */ - - if ((chPtr->mask & ePtr->readyMask) != 0) { - nh.nextHandlerPtr = chPtr->nextPtr; - (*(chPtr->proc))(chPtr->clientData, ePtr->readyMask); - chPtr = nh.nextHandlerPtr; - } else { - chPtr = chPtr->nextPtr; - } - } - - nestedHandlerPtr = nh.nestedHandlerPtr; - - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateChannelHandler -- - * - * Arrange for a given procedure to be invoked whenever the - * channel indicated by the chanPtr arg becomes readable or - * writable. - * - * Results: - * None. - * - * Side effects: - * From now on, whenever the I/O channel given by chanPtr becomes - * ready in the way indicated by mask, proc will be invoked. - * See the manual entry for details on the calling sequence - * to proc. If there is already an event handler for chan, proc - * and clientData, then the mask will be updated. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CreateChannelHandler( - Tcl_Channel chan, /* The channel to create the handler for. */ - int mask, /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: - * indicates conditions under which - * proc should be called. Use 0 to - * disable a registered handler. */ - Tcl_ChannelProc *proc, /* Procedure to call for each - * selected event. */ - ClientData clientData /* Arbitrary data to pass to proc. */ -) -{ - ChannelHandler *chPtr; - Channel *chanPtr; - - chanPtr = (Channel *) chan; - - /* - * Ensure that the channel event source is registered with the Tcl - * notification mechanism. - */ - - if (!channelEventSourceCreated) { - channelEventSourceCreated = 1; - Tcl_CreateEventSource(ChannelHandlerSetupProc, ChannelHandlerCheckProc, - (ClientData) NULL); - Tcl_CreateExitHandler(ChannelEventSourceExitProc, (ClientData) NULL); - } - - /* - * Check whether this channel handler is not already registered. If - * it is not, create a new record, else reuse existing record (smash - * current values). - */ - - for (chPtr = chanPtr->chPtr; - chPtr != (ChannelHandler *) NULL; - chPtr = chPtr->nextPtr) { - if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) && - (chPtr->clientData == clientData)) { - break; - } - } - if (chPtr == (ChannelHandler *) NULL) { - chPtr = (ChannelHandler *) ckalloc((unsigned) sizeof(ChannelHandler)); - chPtr->mask = 0; - chPtr->proc = proc; - chPtr->clientData = clientData; - chPtr->chanPtr = chanPtr; - chPtr->nextPtr = chanPtr->chPtr; - chanPtr->chPtr = chPtr; - } - - /* - * The remainder of the initialization below is done regardless of - * whether or not this is a new record or a modification of an old - * one. - */ - - chPtr->mask = mask; - - /* - * Recompute the interest mask for the channel - this call may actually - * be disabling an existing handler.. - */ - - chanPtr->interestMask = 0; - for (chPtr = chanPtr->chPtr; - chPtr != (ChannelHandler *) NULL; - chPtr = chPtr->nextPtr) { - chanPtr->interestMask |= chPtr->mask; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteChannelHandler -- - * - * Cancel a previously arranged callback arrangement for an IO - * channel. - * - * Results: - * None. - * - * Side effects: - * If a callback was previously registered for this chan, proc and - * clientData , it is removed and the callback will no longer be called - * when the channel becomes ready for IO. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteChannelHandler( - Tcl_Channel chan, /* The channel for which to remove the - * callback. */ - Tcl_ChannelProc *proc, /* The procedure in the callback to delete. */ - ClientData clientData /* The client data in the callback - * to delete. */ -) -{ - ChannelHandler *chPtr, *prevChPtr; - Channel *chanPtr; - NextChannelHandler *nhPtr; - - chanPtr = (Channel *) chan; - - /* - * Find the entry and the previous one in the list. - */ - - for (prevChPtr = (ChannelHandler *) NULL, chPtr = chanPtr->chPtr; - chPtr != (ChannelHandler *) NULL; - chPtr = chPtr->nextPtr) { - if ((chPtr->chanPtr == chanPtr) && (chPtr->clientData == clientData) - && (chPtr->proc == proc)) { - break; - } - prevChPtr = chPtr; - } - - /* - * If ChannelHandlerEventProc is about to process this handler, tell it to - * process the next one instead - we are going to delete *this* one. - */ - - for (nhPtr = nestedHandlerPtr; - nhPtr != (NextChannelHandler *) NULL; - nhPtr = nhPtr->nestedHandlerPtr) { - if (nhPtr->nextHandlerPtr == chPtr) { - nhPtr->nextHandlerPtr = chPtr->nextPtr; - } - } - - /* - * If found, splice the entry out of the list. - */ - - if (chPtr == (ChannelHandler *) NULL) { - return; - } - - if (prevChPtr == (ChannelHandler *) NULL) { - chanPtr->chPtr = chPtr->nextPtr; - } else { - prevChPtr->nextPtr = chPtr->nextPtr; - } - ckfree((char *) chPtr); - - /* - * Recompute the interest list for the channel, so that infinite loops - * will not result if Tcl_DeleteChanelHandler is called inside an event. - */ - - chanPtr->interestMask = 0; - for (chPtr = chanPtr->chPtr; - chPtr != (ChannelHandler *) NULL; - chPtr = chPtr->nextPtr) { - chanPtr->interestMask |= chPtr->mask; - } -} - -/* - *---------------------------------------------------------------------- - * - * ReturnScriptRecord -- - * - * Get a script stored for this channel with this interpreter. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Sets interp->result to the script. - * - *---------------------------------------------------------------------- - */ - -static void -ReturnScriptRecord( - Tcl_Interp *interp, /* The interpreter in which the script - * is to be executed. */ - Channel *chanPtr, /* The channel for which the script is - * stored. */ - int mask /* Events in mask must overlap with events - * for which this script is stored. */ -) -{ - EventScriptRecord *esPtr; - - for (esPtr = chanPtr->scriptRecordPtr; - esPtr != (EventScriptRecord *) NULL; - esPtr = esPtr->nextPtr) { - if ((esPtr->interp == interp) && (esPtr->mask == mask)) { - interp->result = esPtr->script; - return; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * DeleteScriptRecord -- - * - * Delete a script record for this combination of channel, interp - * and mask. - * - * Results: - * None. - * - * Side effects: - * Deletes a script record and cancels a channel event handler. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteScriptRecord( - Tcl_Interp *interp, /* Interpreter in which script was to be - * executed. */ - Channel *chanPtr, /* The channel for which to delete the - * script record (if any). */ - int mask /* Events in mask must exactly match mask - * of script to delete. */ -) -{ - EventScriptRecord *esPtr, *prevEsPtr; - - for (esPtr = chanPtr->scriptRecordPtr, - prevEsPtr = (EventScriptRecord *) NULL; - esPtr != (EventScriptRecord *) NULL; - prevEsPtr = esPtr, esPtr = esPtr->nextPtr) { - if ((esPtr->interp == interp) && (esPtr->mask == mask)) { - if (esPtr == chanPtr->scriptRecordPtr) { - chanPtr->scriptRecordPtr = esPtr->nextPtr; - } else { - prevEsPtr->nextPtr = esPtr->nextPtr; - } - - Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - ChannelEventScriptInvoker, (ClientData) esPtr); - - Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); - ckfree((char *) esPtr); - - break; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * CreateScriptRecord -- - * - * Creates a record to store a script to be executed when a specific - * event fires on a specific channel. - * - * Results: - * None. - * - * Side effects: - * Causes the script to be stored for later execution. - * - *---------------------------------------------------------------------- - */ - -static void -CreateScriptRecord( - Tcl_Interp *interp, /* Interpreter in which to execute - * the stored script. */ - Channel *chanPtr, /* Channel for which script is to - * be stored. */ - int mask, /* Set of events for which script - * will be invoked. */ - char *script /* A copy of this script is stored - * in the newly created record. */ -) -{ - EventScriptRecord *esPtr; - - for (esPtr = chanPtr->scriptRecordPtr; - esPtr != (EventScriptRecord *) NULL; - esPtr = esPtr->nextPtr) { - if ((esPtr->interp == interp) && (esPtr->mask == mask)) { - Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); - esPtr->script = (char *) NULL; - break; - } - } - if (esPtr == (EventScriptRecord *) NULL) { - esPtr = (EventScriptRecord *) ckalloc((unsigned) - sizeof(EventScriptRecord)); - Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - ChannelEventScriptInvoker, (ClientData) esPtr); - esPtr->nextPtr = chanPtr->scriptRecordPtr; - chanPtr->scriptRecordPtr = esPtr; - } - esPtr->chanPtr = chanPtr; - esPtr->interp = interp; - esPtr->mask = mask; - esPtr->script = ckalloc((unsigned) (strlen(script) + 1)); - strcpy(esPtr->script, script); -} - -/* - *---------------------------------------------------------------------- - * - * ChannelEventScriptInvoker -- - * - * Invokes a script scheduled by "fileevent" for when the channel - * becomes ready for IO. This function is invoked by the channel - * handler which was created by the Tcl "fileevent" command. - * - * Results: - * None. - * - * Side effects: - * Whatever the script does. - * - *---------------------------------------------------------------------- - */ - -static void -ChannelEventScriptInvoker( - ClientData clientData, /* The script+interp record. */ - int mask /* Not used. */ -) -{ - Tcl_Interp *interp; /* Interpreter in which to eval the script. */ - Channel *chanPtr; /* The channel for which this handler is - * registered. */ - char *script; /* Script to eval. */ - EventScriptRecord *esPtr; /* The event script + interpreter to eval it - * in. */ - int result; /* Result of call to eval script. */ - - esPtr = (EventScriptRecord *) clientData; - - chanPtr = esPtr->chanPtr; - mask = esPtr->mask; - interp = esPtr->interp; - script = esPtr->script; - - /* - * We must preserve the channel, script and interpreter because each of - * these may be deleted in the evaluation. If an error later occurs, we - * want to have the relevant data around for error reporting and so we - * can safely delete it. - */ - - Tcl_Preserve((ClientData) chanPtr); - Tcl_Preserve((ClientData) script); - Tcl_Preserve((ClientData) interp); - result = Tcl_GlobalEval(esPtr->interp, script); - - /* - * On error, cause a background error and remove the channel handler - * and the script record. - */ - - if (result != TCL_OK) { - Tcl_BackgroundError(interp); - DeleteScriptRecord(interp, chanPtr, mask); - } - Tcl_Release((ClientData) chanPtr); - Tcl_Release((ClientData) script); - Tcl_Release((ClientData) interp); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FileEventCmd -- - * - * This procedure implements the "fileevent" Tcl command. See the - * user documentation for details on what it does. This command is - * based on the Tk command "fileevent" which in turn is based on work - * contributed by Mark Diekhans. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May create a channel handler for the specified channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_FileEventCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Interpreter in which the channel - * for which to create the handler - * is found. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Channel *chanPtr; /* The channel to create - * the handler for. */ - Tcl_Channel chan; /* The opaque type for the channel. */ - int c; /* First char of mode argument. */ - int mask; /* Mask for events of interest. */ - size_t length; /* Length of mode argument. */ - - /* - * Parse arguments. - */ - - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: must be \"", argv[0], - " channelId event ?script?", (char *) NULL); - return TCL_ERROR; - } - c = argv[2][0]; - length = strlen(argv[2]); - if ((c == 'r') && (strncmp(argv[2], "readable", length) == 0)) { - mask = TCL_READABLE; - } else if ((c == 'w') && (strncmp(argv[2], "writable", length) == 0)) { - mask = TCL_WRITABLE; - } else { - Tcl_AppendResult(interp, "bad event name \"", argv[2], - "\": must be readable or writable", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(interp, argv[1], NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - - chanPtr = (Channel *) chan; - if ((chanPtr->flags & mask) == 0) { - Tcl_AppendResult(interp, "channel is not ", - (mask == TCL_READABLE) ? "readable" : "writable", - (char *) NULL); - return TCL_ERROR; - } - - /* - * If we are supposed to return the script, do so. - */ - - if (argc == 3) { - ReturnScriptRecord(interp, chanPtr, mask); - return TCL_OK; - } - - /* - * If we are supposed to delete a stored script, do so. - */ - - if (argv[3][0] == 0) { - DeleteScriptRecord(interp, chanPtr, mask); - return TCL_OK; - } - - /* - * Make the script record that will link between the event and the - * script to invoke. This also creates a channel event handler which - * will evaluate the script in the supplied interpreter. - */ - - CreateScriptRecord(interp, chanPtr, mask, argv[3]); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclTestChannelCmd -- - * - * Implements the Tcl "testchannel" debugging command and its - * subcommands. This is part of the testing environment but must be - * in this file instead of tclTest.c because it needs access to the - * fields of struct Channel. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -TclTestChannelCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Interpreter for result. */ - int argc, /* Count of additional args. */ - char **argv /* Additional arg strings. */ -) -{ - char *cmdName; /* Sub command. */ - Tcl_HashTable *hTblPtr; /* Hash table of channels. */ - Tcl_HashSearch hSearch; /* Search variable. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Channel *chanPtr; /* The actual channel. */ - Tcl_Channel chan; /* The opaque type. */ - size_t len; /* Length of subcommand string. */ - int IOQueued; /* How much IO is queued inside channel? */ - ChannelBuffer *bufPtr; /* For iterating over queued IO. */ - char buf[128]; /* For sprintf. */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " subcommand ?additional args..?\"", (char *) NULL); - return TCL_ERROR; - } - cmdName = argv[1]; - len = strlen(cmdName); - - chanPtr = (Channel *) NULL; - if (argc > 2) { - chan = Tcl_GetChannel(interp, argv[2], NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - chanPtr = (Channel *) chan; - } - - if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " info channelName\"", (char *) NULL); - return TCL_ERROR; - } - Tcl_AppendElement(interp, argv[2]); - Tcl_AppendElement(interp, chanPtr->typePtr->typeName); - if (chanPtr->flags & TCL_READABLE) { - Tcl_AppendElement(interp, "read"); - } else { - Tcl_AppendElement(interp, ""); - } - if (chanPtr->flags & TCL_WRITABLE) { - Tcl_AppendElement(interp, "write"); - } else { - Tcl_AppendElement(interp, ""); - } - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - Tcl_AppendElement(interp, "nonblocking"); - } else { - Tcl_AppendElement(interp, "blocking"); - } - if (chanPtr->flags & CHANNEL_LINEBUFFERED) { - Tcl_AppendElement(interp, "line"); - } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { - Tcl_AppendElement(interp, "none"); - } else { - Tcl_AppendElement(interp, "full"); - } - if (chanPtr->flags & BG_FLUSH_SCHEDULED) { - Tcl_AppendElement(interp, "async_flush"); - } else { - Tcl_AppendElement(interp, ""); - } - if (chanPtr->flags & CHANNEL_EOF) { - Tcl_AppendElement(interp, "eof"); - } else { - Tcl_AppendElement(interp, ""); - } - if (chanPtr->flags & CHANNEL_BLOCKED) { - Tcl_AppendElement(interp, "blocked"); - } else { - Tcl_AppendElement(interp, "unblocked"); - } - if (chanPtr->inputTranslation == TCL_TRANSLATE_AUTO) { - Tcl_AppendElement(interp, "auto"); - if (chanPtr->flags & INPUT_SAW_CR) { - Tcl_AppendElement(interp, "saw_cr"); - } else { - Tcl_AppendElement(interp, ""); - } - } else if (chanPtr->inputTranslation == TCL_TRANSLATE_LF) { - Tcl_AppendElement(interp, "lf"); - Tcl_AppendElement(interp, ""); - } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CR) { - Tcl_AppendElement(interp, "cr"); - Tcl_AppendElement(interp, ""); - } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CRLF) { - Tcl_AppendElement(interp, "crlf"); - if (chanPtr->flags & INPUT_SAW_CR) { - Tcl_AppendElement(interp, "queued_cr"); - } else { - Tcl_AppendElement(interp, ""); - } - } - if (chanPtr->outputTranslation == TCL_TRANSLATE_AUTO) { - Tcl_AppendElement(interp, "auto"); - } else if (chanPtr->outputTranslation == TCL_TRANSLATE_LF) { - Tcl_AppendElement(interp, "lf"); - } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CR) { - Tcl_AppendElement(interp, "cr"); - } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CRLF) { - Tcl_AppendElement(interp, "crlf"); - } - for (IOQueued = 0, bufPtr = chanPtr->inQueueHead; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; - } - sprintf(buf, "%d", IOQueued); - Tcl_AppendElement(interp, buf); - - IOQueued = 0; - if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { - IOQueued = chanPtr->curOutPtr->nextAdded - - chanPtr->curOutPtr->nextRemoved; - } - for (bufPtr = chanPtr->outQueueHead; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - sprintf(buf, "%d", IOQueued); - Tcl_AppendElement(interp, buf); - - sprintf(buf, "%d", Tcl_Tell((Tcl_Channel) chanPtr)); - Tcl_AppendElement(interp, buf); - - sprintf(buf, "%d", chanPtr->refCount); - Tcl_AppendElement(interp, buf); - - return TCL_OK; - } - - if ((cmdName[0] == 'i') && - (strncmp(cmdName, "inputbuffered", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", - (char *) NULL); - return TCL_ERROR; - } - - for (IOQueued = 0, bufPtr = chanPtr->inQueueHead; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; - } - sprintf(buf, "%d", IOQueued); - Tcl_AppendResult(interp, buf, (char *) NULL); - return TCL_OK; - } - - if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", - (char *) NULL); - return TCL_ERROR; - } - - if (chanPtr->flags & TCL_READABLE) { - Tcl_AppendElement(interp, "read"); - } else { - Tcl_AppendElement(interp, ""); - } - if (chanPtr->flags & TCL_WRITABLE) { - Tcl_AppendElement(interp, "write"); - } else { - Tcl_AppendElement(interp, ""); - } - return TCL_OK; - } - - if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", - (char *) NULL); - return TCL_ERROR; - } - Tcl_AppendResult(interp, chanPtr->channelName, (char *) NULL); - return TCL_OK; - } - - if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) { - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - return TCL_OK; - } - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); - } - return TCL_OK; - } - - if ((cmdName[0] == 'o') && - (strncmp(cmdName, "outputbuffered", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", - (char *) NULL); - return TCL_ERROR; - } - - IOQueued = 0; - if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { - IOQueued = chanPtr->curOutPtr->nextAdded - - chanPtr->curOutPtr->nextRemoved; - } - for (bufPtr = chanPtr->outQueueHead; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - sprintf(buf, "%d", IOQueued); - Tcl_AppendResult(interp, buf, (char *) NULL); - return TCL_OK; - } - - if ((cmdName[0] == 'q') && - (strncmp(cmdName, "queuedcr", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", - (char *) NULL); - return TCL_ERROR; - } - - Tcl_AppendResult(interp, - (chanPtr->flags & INPUT_SAW_CR) ? "1" : "0", - (char *) NULL); - return TCL_OK; - } - - if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) { - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - return TCL_OK; - } - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - chanPtr = (Channel *) Tcl_GetHashValue(hPtr); - if (chanPtr->flags & TCL_READABLE) { - Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); - } - } - return TCL_OK; - } - - if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", - (char *) NULL); - return TCL_ERROR; - } - - sprintf(buf, "%d", chanPtr->refCount); - Tcl_AppendResult(interp, buf, (char *) NULL); - return TCL_OK; - } - - if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "channel name required", - (char *) NULL); - return TCL_ERROR; - } - Tcl_AppendResult(interp, chanPtr->typePtr->typeName, (char *) NULL); - return TCL_OK; - } - - if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) { - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - return TCL_OK; - } - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - chanPtr = (Channel *) Tcl_GetHashValue(hPtr); - if (chanPtr->flags & TCL_WRITABLE) { - Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); - } - } - return TCL_OK; - } - - Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ", - "info, open, readable, or writable", - (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclTestChannelEventCmd -- - * - * This procedure implements the "testchannelevent" command. It is - * used to test the Tcl channel event mechanism. It is present in - * this file instead of tclTest.c because it needs access to the - * internal structure of the channel. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates, deletes and returns channel event handlers. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -TclTestChannelEventCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Channel *chanPtr; - EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr; - char *cmd; - int index, i, mask, len; - - if ((argc < 3) || (argc > 5)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName cmd ?arg1? ?arg2?\"", (char *) NULL); - return TCL_ERROR; - } - chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL); - if (chanPtr == (Channel *) NULL) { - return TCL_ERROR; - } - cmd = argv[2]; - len = strlen(cmd); - if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName add eventSpec script\"", (char *) NULL); - return TCL_ERROR; - } - if (strcmp(argv[3], "readable") == 0) { - mask = TCL_READABLE; - } else if (strcmp(argv[3], "writable") == 0) { - mask = TCL_WRITABLE; - } else { - Tcl_AppendResult(interp, "bad event name \"", argv[3], - "\": must be readable or writable", (char *) NULL); - return TCL_ERROR; - } - - esPtr = (EventScriptRecord *) ckalloc((unsigned) - sizeof(EventScriptRecord)); - esPtr->nextPtr = chanPtr->scriptRecordPtr; - chanPtr->scriptRecordPtr = esPtr; - - esPtr->chanPtr = chanPtr; - esPtr->interp = interp; - esPtr->mask = mask; - esPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); - strcpy(esPtr->script, argv[4]); - - Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - ChannelEventScriptInvoker, (ClientData) esPtr); - - return TCL_OK; - } - - if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName delete index\"", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { - return TCL_ERROR; - } - if (index < 0) { - Tcl_AppendResult(interp, "bad event index: ", argv[3], - ": must be nonnegative", (char *) NULL); - return TCL_ERROR; - } - for (i = 0, esPtr = chanPtr->scriptRecordPtr; - (i < index) && (esPtr != (EventScriptRecord *) NULL); - i++, esPtr = esPtr->nextPtr) { - /* Empty loop body. */ - } - if (esPtr == (EventScriptRecord *) NULL) { - Tcl_AppendResult(interp, "bad event index ", argv[3], - ": out of range", (char *) NULL); - return TCL_ERROR; - } - if (esPtr == chanPtr->scriptRecordPtr) { - chanPtr->scriptRecordPtr = esPtr->nextPtr; - } else { - for (prevEsPtr = chanPtr->scriptRecordPtr; - (prevEsPtr != (EventScriptRecord *) NULL) && - (prevEsPtr->nextPtr != esPtr); - prevEsPtr = prevEsPtr->nextPtr) { - /* Empty loop body. */ - } - if (prevEsPtr == (EventScriptRecord *) NULL) { - panic("TclTestChannelEventCmd: damaged event script list"); - } - prevEsPtr->nextPtr = esPtr->nextPtr; - } - Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - ChannelEventScriptInvoker, (ClientData) esPtr); - Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); - ckfree((char *) esPtr); - - return TCL_OK; - } - - if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName list\"", (char *) NULL); - return TCL_ERROR; - } - for (esPtr = chanPtr->scriptRecordPtr; - esPtr != (EventScriptRecord *) NULL; - esPtr = esPtr->nextPtr) { - Tcl_AppendElement(interp, - esPtr->mask == TCL_READABLE ? "readable" : "writable"); - Tcl_AppendElement(interp, esPtr->script); - } - return TCL_OK; - } - - if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName removeall\"", (char *) NULL); - return TCL_ERROR; - } - for (esPtr = chanPtr->scriptRecordPtr; - esPtr != (EventScriptRecord *) NULL; - esPtr = nextEsPtr) { - nextEsPtr = esPtr->nextPtr; - Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - ChannelEventScriptInvoker, (ClientData) esPtr); - Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); - ckfree((char *) esPtr); - } - chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; - return TCL_OK; - } - - Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ", - "add, delete, list, or removeall", (char *) NULL); - return TCL_ERROR; - -} diff --git a/cde/programs/dtdocbook/tcl/tclIOCmd.c b/cde/programs/dtdocbook/tcl/tclIOCmd.c deleted file mode 100644 index de3de4f4..00000000 --- a/cde/programs/dtdocbook/tcl/tclIOCmd.c +++ /dev/null @@ -1,1552 +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: tclIOCmd.c /main/2 1996/08/08 14:44:34 cde-hp $ */ -/* - * tclIOCmd.c -- - * - * Contains the definitions of most of the Tcl commands relating to IO. - * - * 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: @(#) tclIOCmd.c 1.94 96/04/15 06:40:02 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * Return at most this number of bytes in one call to Tcl_Read: - */ - -#define TCL_READ_CHUNK_SIZE 4096 - -/* - * Callback structure for accept callback in a TCP server. - */ - -typedef struct AcceptCallback { - char *script; /* Script to invoke. */ - Tcl_Interp *interp; /* Interpreter in which to run it. */ -} AcceptCallback; - -/* - * Static functions for this file: - */ - -static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData, - Tcl_Channel chan, char *address, int port)); -static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp, - AcceptCallback *acceptCallbackPtr)); -static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); -static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData)); -static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( - Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr)); - -/* - *---------------------------------------------------------------------- - * - * Tcl_PutsCmd -- - * - * This procedure is invoked to process the "puts" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Produces output on a channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_PutsCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Channel chan; /* The channel to puts on. */ - int i; /* Counter. */ - int newline; /* Add a newline at end? */ - char *channelId; /* Name of channel for puts. */ - int result; /* Result of puts operation. */ - int mode; /* Mode in which channel is opened. */ - - i = 1; - newline = 1; - if ((argc >= 2) && (strcmp(argv[1], "-nonewline") == 0)) { - newline = 0; - i++; - } - if ((i < (argc-3)) || (i >= argc)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?-nonewline? ?channelId? string\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * The code below provides backwards compatibility with an old - * form of the command that is no longer recommended or documented. - */ - - if (i == (argc-3)) { - if (strncmp(argv[i+2], "nonewline", strlen(argv[i+2])) != 0) { - Tcl_AppendResult(interp, "bad argument \"", argv[i+2], - "\": should be \"nonewline\"", (char *) NULL); - return TCL_ERROR; - } - newline = 0; - } - if (i == (argc-1)) { - channelId = "stdout"; - } else { - channelId = argv[i]; - i++; - } - chan = Tcl_GetChannel(interp, channelId, &mode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", channelId, - "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; - } - - result = Tcl_Write(chan, argv[i], -1); - if (result < 0) { - goto error; - } - if (newline != 0) { - result = Tcl_Write(chan, "\n", 1); - if (result < 0) { - goto error; - } - } - return TCL_OK; -error: - Tcl_AppendResult(interp, "error writing \"", Tcl_GetChannelName(chan), - "\": ", Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FlushCmd -- - * - * This procedure is called to process the Tcl "flush" command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May cause output to appear on the specified channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_FlushCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Channel chan; /* The channel to flush on. */ - int result; /* Result of call to channel - * level function. */ - int mode; /* Mode in which channel is opened. */ - - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId\"", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(interp, argv[1], &mode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", argv[1], - "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; - } - - result = Tcl_Flush(chan); - if (result != TCL_OK) { - Tcl_AppendResult(interp, "error flushing \"", Tcl_GetChannelName(chan), - "\": ", Tcl_PosixError(interp), (char *) NULL); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetsCmd -- - * - * This procedure is called to process the Tcl "gets" command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May consume input from channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_GetsCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Channel chan; /* The channel to read from. */ - char *varName; /* Assign to this variable? */ - char buf[128]; /* Buffer to store string - * representation of how long - * a line was read. */ - Tcl_DString ds; /* Dynamic string to hold the - * buffer for the line just read. */ - int lineLen; /* Length of line just read. */ - int mode; /* Mode in which channel is opened. */ - - if ((argc != 2) && (argc != 3)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId ?varName?\"", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(interp, argv[1], &mode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", argv[1], - "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; - } - - if (argc != 3) { - varName = (char *) NULL; - } else { - varName = argv[2]; - } - Tcl_DStringInit(&ds); - lineLen = Tcl_Gets(chan, &ds); - if (lineLen < 0) { - if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { - Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, "error reading \"", - Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), - (char *) NULL); - return TCL_ERROR; - } - lineLen = -1; - } - if (varName == (char *) NULL) { - Tcl_DStringResult(interp, &ds); - } else { - if (Tcl_SetVar(interp, varName, Tcl_DStringValue(&ds), - TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_ResetResult(interp); - sprintf(buf, "%d", lineLen); - Tcl_AppendResult(interp, buf, (char *) NULL); - } - Tcl_DStringFree(&ds); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ReadCmd -- - * - * This procedure is invoked to process the Tcl "read" command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May consume input from channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_ReadCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Channel chan; /* The channel to read from. */ - int newline, i; /* Discard newline at end? */ - int toRead; /* How many bytes to read? */ - int toReadNow; /* How many bytes to attempt to - * read in the current iteration? */ - int charactersRead; /* How many characters were read? */ - int charactersReadNow; /* How many characters were read - * in this iteration? */ - int mode; /* Mode in which channel is opened. */ - Tcl_DString ds; /* Used to accumulate the data - * read by Tcl_Read. */ - int bufSize; /* Channel buffer size; used to decide - * in what chunk sizes to read from - * the channel. */ - - if ((argc != 2) && (argc != 3)) { -argerror: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId ?numBytes?\" or \"", argv[0], - " ?-nonewline? channelId\"", (char *) NULL); - return TCL_ERROR; - } - i = 1; - newline = 0; - if (strcmp(argv[i], "-nonewline") == 0) { - newline = 1; - i++; - } - - if (i == argc) { - goto argerror; - } - - chan = Tcl_GetChannel(interp, argv[i], &mode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", argv[i], - "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; - } - - i++; /* Consumed channel name. */ - - /* - * Compute how many bytes to read, and see whether the final - * newline should be dropped. - */ - - toRead = INT_MAX; - if (i < argc) { - if (isdigit((unsigned char) (argv[i][0]))) { - if (Tcl_GetInt(interp, argv[i], &toRead) != TCL_OK) { - return TCL_ERROR; - } - } else if (strcmp(argv[i], "nonewline") == 0) { - newline = 1; - } else { - Tcl_AppendResult(interp, "bad argument \"", argv[i], - "\": should be \"nonewline\"", (char *) NULL); - return TCL_ERROR; - } - } - - bufSize = Tcl_GetChannelBufferSize(chan); - Tcl_DStringInit(&ds); - for (charactersRead = 0; charactersRead < toRead; ) { - toReadNow = toRead - charactersRead; - if (toReadNow > bufSize) { - toReadNow = bufSize; - } - Tcl_DStringSetLength(&ds, charactersRead + toReadNow); - charactersReadNow = - Tcl_Read(chan, Tcl_DStringValue(&ds) + charactersRead, toReadNow); - if (charactersReadNow < 0) { - Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, "error reading \"", - Tcl_GetChannelName(chan), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - - /* - * If we had a short read it means that we have either EOF - * or BLOCKED on the channel, so break out. - */ - - charactersRead += charactersReadNow; - if (charactersReadNow < toReadNow) { - break; /* Out of "for" loop. */ - } - } - - /* - * Tcl_Read does not put a NULL at the end of the string, so we must - * do it here. - */ - - Tcl_DStringSetLength(&ds, charactersRead); - Tcl_DStringResult(interp, &ds); - Tcl_DStringFree(&ds); - - /* - * If requested, remove the last newline in the channel if at EOF. - */ - - if ((charactersRead > 0) && (newline) && - (interp->result[charactersRead-1] == '\n')) { - interp->result[charactersRead-1] = '\0'; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclUnsupported0Cmd -- - * - * This procedure is invoked to process the Tcl "unsupported0" command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May copy a chunk from one channel to another. - * - *---------------------------------------------------------------------- - */ - -int -TclUnsupported0Cmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Interpreter in which both channels - * are defined. */ - int argc, /* How many arguments? */ - char **argv /* The argument strings. */ -) -{ - Tcl_Channel inChan, outChan; - int requested; - char *bufPtr; - int actuallyRead, actuallyWritten, totalRead, toReadNow, mode; - - /* - * Assume we want to copy the entire channel. - */ - - requested = INT_MAX; - - if ((argc < 3) || (argc > 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " inChanId outChanId ?chunkSize?\"", (char *) NULL); - return TCL_ERROR; - } - inChan = Tcl_GetChannel(interp, argv[1], &mode); - if (inChan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", argv[1], - "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; - } - outChan = Tcl_GetChannel(interp, argv[2], &mode); - if (outChan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", argv[2], - "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; - } - - if (argc == 4) { - if (Tcl_GetInt(interp, argv[3], &requested) != TCL_OK) { - return TCL_ERROR; - } - if (requested < 0) { - requested = INT_MAX; - } - } - - bufPtr = ckalloc((unsigned) TCL_READ_CHUNK_SIZE); - for (totalRead = 0; - requested > 0; - totalRead += actuallyRead, requested -= actuallyRead) { - toReadNow = requested; - if (toReadNow > TCL_READ_CHUNK_SIZE) { - toReadNow = TCL_READ_CHUNK_SIZE; - } - actuallyRead = Tcl_Read(inChan, bufPtr, toReadNow); - if (actuallyRead < 0) { - ckfree(bufPtr); - Tcl_AppendResult(interp, argv[0], ": ", Tcl_GetChannelName(inChan), - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - if (actuallyRead == 0) { - ckfree(bufPtr); - sprintf(interp->result, "%d", totalRead); - return TCL_OK; - } - actuallyWritten = Tcl_Write(outChan, bufPtr, actuallyRead); - if (actuallyWritten < 0) { - ckfree(bufPtr); - Tcl_AppendResult(interp, argv[0], ": ", Tcl_GetChannelName(outChan), - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - } - ckfree(bufPtr); - - sprintf(interp->result, "%d", totalRead); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SeekCmd -- - * - * This procedure is invoked to process the Tcl "seek" command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Moves the position of the access point on the specified channel. - * May flush queued output. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_SeekCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Channel chan; /* The channel to tell on. */ - int offset, mode; /* Where to seek? */ - int result; /* Of calling Tcl_Seek. */ - - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId offset ?origin?\"", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(interp, argv[1], NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) { - return TCL_ERROR; - } - mode = SEEK_SET; - if (argc == 4) { - size_t length; - int c; - - length = strlen(argv[3]); - c = argv[3][0]; - if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) { - mode = SEEK_SET; - } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) { - mode = SEEK_CUR; - } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) { - mode = SEEK_END; - } else { - Tcl_AppendResult(interp, "bad origin \"", argv[3], - "\": should be start, current, or end", (char *) NULL); - return TCL_ERROR; - } - } - - result = Tcl_Seek(chan, offset, mode); - if (result < 0) { - Tcl_AppendResult(interp, "error during seek on \"", - Tcl_GetChannelName(chan), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_TellCmd -- - * - * This procedure is invoked to process the Tcl "tell" command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_TellCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Channel chan; /* The channel to tell on. */ - - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId\"", (char *) NULL); - return TCL_ERROR; - } - /* - * Try to find a channel with the right name and permissions in - * the IO channel table of this interpreter. - */ - - chan = Tcl_GetChannel(interp, argv[1], NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - sprintf(interp->result, "%d", Tcl_Tell(chan)); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CloseCmd -- - * - * This procedure is invoked to process the Tcl "close" command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May discard queued input; may flush queued output. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_CloseCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Channel chan; /* The channel to close. */ - int len; /* Length of error output. */ - - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId\"", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(interp, argv[1], NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { - - /* - * If there is an error message and it ends with a newline, remove - * the newline. This is done for command pipeline channels where the - * error output from the subprocesses is stored in interp->result. - * - * NOTE: This is likely to not have any effect on regular error - * messages produced by drivers during the closing of a channel, - * because the Tcl convention is that such error messages do not - * have a terminating newline. - */ - - len = strlen(interp->result); - if ((len > 0) && (interp->result[len - 1] == '\n')) { - interp->result[len - 1] = '\0'; - } - - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FconfigureCmd -- - * - * This procedure is invoked to process the Tcl "fconfigure" command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May modify the behavior of an IO channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_FconfigureCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Channel chan; /* The channel to set a mode on. */ - int result; /* Of Tcl_Set/GetChannelOption. */ - int i; /* Iterate over arg-value pairs. */ - Tcl_DString ds; /* DString to hold result of - * calling Tcl_GetChannelOption. */ - - if ((argc < 2) || (((argc % 2) == 1) && (argc != 3))) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId ?optionName? ?value? ?optionName value?...\"", - (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(interp, argv[1], NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if (argc == 2) { - Tcl_DStringInit(&ds); - if (Tcl_GetChannelOption(chan, (char *) NULL, &ds) != TCL_OK) { - Tcl_AppendResult(interp, "option retrieval failed", - (char *) NULL); - return TCL_ERROR; - } - Tcl_DStringResult(interp, &ds); - Tcl_DStringFree(&ds); - return TCL_OK; - } - if (argc == 3) { - Tcl_DStringInit(&ds); - if (Tcl_GetChannelOption(chan, argv[2], &ds) != TCL_OK) { - Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, "bad option \"", argv[2], - "\": must be -blocking, -buffering, -buffersize, ", - "-eofchar, -translation, ", - "or a channel type specific option", (char *) NULL); - return TCL_ERROR; - } - Tcl_DStringResult(interp, &ds); - Tcl_DStringFree(&ds); - return TCL_OK; - } - for (i = 3; i < argc; i += 2) { - result = Tcl_SetChannelOption(interp, chan, argv[i-1], argv[i]); - if (result != TCL_OK) { - return result; - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EofCmd -- - * - * This procedure is invoked to process the Tcl "eof" command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Sets interp->result to "0" or "1" depending on whether the - * specified channel has an EOF condition. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_EofCmd( - ClientData unused, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Channel chan; /* The channel to query for EOF. */ - int mode; /* Mode in which channel is opened. */ - - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId\"", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(interp, argv[1], &mode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - sprintf(interp->result, "%d", Tcl_Eof(chan) ? 1 : 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ExecCmd -- - * - * This procedure is invoked to process the "exec" 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_ExecCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ -#ifdef MAC_TCL - Tcl_AppendResult(interp, "exec not implemented under Mac OS", - (char *)NULL); - return TCL_ERROR; -#else /* !MAC_TCL */ - int keepNewline, firstWord, background, length, result; - Tcl_Channel chan; - Tcl_DString ds; - int readSoFar, readNow, bufSize; - - /* - * Check for a leading "-keepnewline" argument. - */ - - keepNewline = 0; - for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-'); - firstWord++) { - if (strcmp(argv[firstWord], "-keepnewline") == 0) { - keepNewline = 1; - } else if (strcmp(argv[firstWord], "--") == 0) { - firstWord++; - break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argv[firstWord], - "\": must be -keepnewline or --", (char *) NULL); - return TCL_ERROR; - } - } - - if (argc <= firstWord) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? arg ?arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * See if the command is to be run in background. - */ - - background = 0; - if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) { - argc--; - argv[argc] = NULL; - background = 1; - } - - chan = Tcl_OpenCommandChannel(interp, argc-firstWord, - argv+firstWord, - (background ? 0 : TCL_STDOUT | TCL_STDERR)); - - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - - if (background) { - - /* - * Get the list of PIDs from the pipeline into interp->result and - * detach the PIDs (instead of waiting for them). - */ - - TclGetAndDetachPids(interp, chan); - - if (Tcl_Close(interp, chan) != TCL_OK) { - return TCL_ERROR; - } - return TCL_OK; - } - - if (Tcl_GetChannelFile(chan, TCL_READABLE) != NULL) { -#define EXEC_BUFFER_SIZE 4096 - - Tcl_DStringInit(&ds); - readSoFar = 0; bufSize = 0; - while (1) { - bufSize += EXEC_BUFFER_SIZE; - Tcl_DStringSetLength(&ds, bufSize); - readNow = Tcl_Read(chan, Tcl_DStringValue(&ds) + readSoFar, - EXEC_BUFFER_SIZE); - if (readNow < 0) { - Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, - "error reading output from command: ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - readSoFar += readNow; - if (readNow < EXEC_BUFFER_SIZE) { - break; /* Out of "while (1)" loop. */ - } - } - Tcl_DStringSetLength(&ds, readSoFar); - Tcl_DStringResult(interp, &ds); - Tcl_DStringFree(&ds); - } - - result = Tcl_Close(interp, chan); - - /* - * If the last character of interp->result is a newline, then remove - * the newline character (the newline would just confuse things). - * Special hack: must replace the old terminating null character - * as a signal to Tcl_AppendResult et al. that we've mucked with - * the string. - */ - - length = strlen(interp->result); - if (!keepNewline && (length > 0) && - (interp->result[length-1] == '\n')) { - interp->result[length-1] = '\0'; - interp->result[length] = 'x'; - } - - return result; -#endif /* !MAC_TCL */ -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FblockedCmd -- - * - * This procedure is invoked to process the Tcl "fblocked" command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Sets interp->result to "0" or "1" depending on whether the - * a preceding input operation on the channel would have blocked. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_FblockedCmd( - ClientData unused, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Channel chan; /* The channel to query for blocked. */ - int mode; /* Mode in which channel was opened. */ - - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId\"", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(interp, argv[1], &mode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", argv[1], - "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; - } - - sprintf(interp->result, "%d", Tcl_InputBlocked(chan) ? 1 : 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenCmd -- - * - * This procedure is invoked to process the "open" 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_OpenCmd( - ClientData notUsed, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int pipeline, prot; - char *modeString; - Tcl_Channel chan; - - if ((argc < 2) || (argc > 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " fileName ?access? ?permissions?\"", (char *) NULL); - return TCL_ERROR; - } - prot = 0666; - if (argc == 2) { - modeString = "r"; - } else { - modeString = argv[2]; - if (argc == 4) { - if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) { - return TCL_ERROR; - } - } - } - - pipeline = 0; - if (argv[1][0] == '|') { - pipeline = 1; - } - - /* - * Open the file or create a process pipeline. - */ - - if (!pipeline) { - chan = Tcl_OpenFileChannel(interp, argv[1], modeString, prot); - } else { - int mode, seekFlag, cmdArgc; - char **cmdArgv; - - if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) { - return TCL_ERROR; - } - - mode = TclGetOpenMode(interp, modeString, &seekFlag); - if (mode == -1) { - chan = NULL; - } else { - int flags = TCL_STDERR | TCL_ENFORCE_MODE; - switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { - case O_RDONLY: - flags |= TCL_STDOUT; - break; - case O_WRONLY: - flags |= TCL_STDIN; - break; - case O_RDWR: - flags |= (TCL_STDIN | TCL_STDOUT); - break; - default: - panic("Tcl_OpenCmd: invalid mode value"); - break; - } - chan = Tcl_OpenCommandChannel(interp, cmdArgc, cmdArgv, flags); - } - ckfree((char *) cmdArgv); - } - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TcpAcceptCallbacksDeleteProc -- - * - * Assocdata cleanup routine called when an interpreter is being - * deleted to set the interp field of all the accept callback records - * registered with the interpreter to NULL. This will prevent the - * interpreter from being used in the future to eval accept scripts. - * - * Results: - * None. - * - * Side effects: - * Deallocates memory and sets the interp field of all the accept - * callback records to NULL to prevent this interpreter from being - * used subsequently to eval accept scripts. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -TcpAcceptCallbacksDeleteProc( - ClientData clientData, /* Data which was passed when the assocdata - * was registered. */ - Tcl_Interp *interp /* Interpreter being deleted - not used. */ -) -{ - Tcl_HashTable *hTblPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - AcceptCallback *acceptCallbackPtr; - - hTblPtr = (Tcl_HashTable *) clientData; - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); - acceptCallbackPtr->interp = (Tcl_Interp *) NULL; - } - Tcl_DeleteHashTable(hTblPtr); - ckfree((char *) hTblPtr); -} - -/* - *---------------------------------------------------------------------- - * - * RegisterTcpServerInterpCleanup -- - * - * Registers an accept callback record to have its interp - * field set to NULL when the interpreter is deleted. - * - * Results: - * None. - * - * Side effects: - * When, in the future, the interpreter is deleted, the interp - * field of the accept callback data structure will be set to - * NULL. This will prevent attempts to eval the accept script - * in a deleted interpreter. - * - *---------------------------------------------------------------------- - */ - -static void -RegisterTcpServerInterpCleanup( - Tcl_Interp *interp, /* Interpreter for which we want to be - * informed of deletion. */ - AcceptCallback *acceptCallbackPtr - /* The accept callback record whose - * interp field we want set to NULL when - * the interpreter is deleted. */ -) -{ - Tcl_HashTable *hTblPtr; /* Hash table for accept callback - * records to smash when the interpreter - * will be deleted. */ - Tcl_HashEntry *hPtr; /* Entry for this record. */ - int new; /* Is the entry new? */ - - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", - NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); - (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", - TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); - } - hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); - if (!new) { - panic("RegisterTcpServerCleanup: damaged accept record table"); - } - Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); -} - -/* - *---------------------------------------------------------------------- - * - * UnregisterTcpServerInterpCleanupProc -- - * - * Unregister a previously registered accept callback record. The - * interp field of this record will no longer be set to NULL in - * the future when the interpreter is deleted. - * - * Results: - * None. - * - * Side effects: - * Prevents the interp field of the accept callback record from - * being set to NULL in the future when the interpreter is deleted. - * - *---------------------------------------------------------------------- - */ - -static void -UnregisterTcpServerInterpCleanupProc( - Tcl_Interp *interp, /* Interpreter in which the accept callback - * record was registered. */ - AcceptCallback *acceptCallbackPtr - /* The record for which to delete the - * registration. */ -) -{ - Tcl_HashTable *hTblPtr; - Tcl_HashEntry *hPtr; - - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - return; - } - hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); - if (hPtr == (Tcl_HashEntry *) NULL) { - return; - } - Tcl_DeleteHashEntry(hPtr); -} - -/* - *---------------------------------------------------------------------- - * - * AcceptCallbackProc -- - * - * This callback is invoked by the TCP channel driver when it - * accepts a new connection from a client on a server socket. - * - * Results: - * None. - * - * Side effects: - * Whatever the script does. - * - *---------------------------------------------------------------------- - */ - -static void -AcceptCallbackProc( - ClientData callbackData, /* The data stored when the callback - * was created in the call to - * Tcl_OpenTcpServer. */ - Tcl_Channel chan, /* Channel for the newly accepted - * connection. */ - char *address, /* Address of client that was - * accepted. */ - int port /* Port of client that was accepted. */ -) -{ - AcceptCallback *acceptCallbackPtr; - Tcl_Interp *interp; - char *script; - char portBuf[10]; - int result; - - acceptCallbackPtr = (AcceptCallback *) callbackData; - - /* - * Check if the callback is still valid; the interpreter may have gone - * away, this is signalled by setting the interp field of the callback - * data to NULL. - */ - - if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { - - script = acceptCallbackPtr->script; - interp = acceptCallbackPtr->interp; - - Tcl_Preserve((ClientData) script); - Tcl_Preserve((ClientData) interp); - - sprintf(portBuf, "%d", port); - Tcl_RegisterChannel(interp, chan); - result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), - " ", address, " ", portBuf, (char *) NULL); - if (result != TCL_OK) { - Tcl_BackgroundError(interp); - Tcl_UnregisterChannel(interp, chan); - } - Tcl_Release((ClientData) interp); - Tcl_Release((ClientData) script); - } else { - - /* - * The interpreter has been deleted, so there is no useful - * way to utilize the client socket - just close it. - */ - - Tcl_Close((Tcl_Interp *) NULL, chan); - } -} - -/* - *---------------------------------------------------------------------- - * - * TcpServerCloseProc -- - * - * This callback is called when the TCP server channel for which it - * was registered is being closed. It informs the interpreter in - * which the accept script is evaluated (if that interpreter still - * exists) that this channel no longer needs to be informed if the - * interpreter is deleted. - * - * Results: - * None. - * - * Side effects: - * In the future, if the interpreter is deleted this channel will - * no longer be informed. - * - *---------------------------------------------------------------------- - */ - -static void -TcpServerCloseProc( - ClientData callbackData /* The data passed in the call to - * Tcl_CreateCloseHandler. */ -) -{ - AcceptCallback *acceptCallbackPtr; - /* The actual data. */ - - acceptCallbackPtr = (AcceptCallback *) callbackData; - if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { - UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, - acceptCallbackPtr); - } - Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); - ckfree((char *) acceptCallbackPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SocketCmd -- - * - * This procedure is invoked to process the "socket" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates a socket based channel. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SocketCmd( - ClientData notUsed, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int a, server, port; - char *arg, *copyScript, *host, *script; - char *myaddr = NULL; - int myport = 0; - int async = 0; - Tcl_Channel chan; - AcceptCallback *acceptCallbackPtr; - - server = 0; - script = NULL; - - if (TclHasSockets(interp) != TCL_OK) { - return TCL_ERROR; - } - - for (a = 1; a < argc; a++) { - arg = argv[a]; - if (arg[0] == '-') { - if (strcmp(arg, "-server") == 0) { - if (async == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", - (char *) NULL); - return TCL_ERROR; - } - server = 1; - a++; - if (a >= argc) { - Tcl_AppendResult(interp, - "no argument given for -server option", - (char *) NULL); - return TCL_ERROR; - } - script = argv[a]; - } else if (strcmp(arg, "-myaddr") == 0) { - a++; - if (a >= argc) { - Tcl_AppendResult(interp, - "no argument given for -myaddr option", - (char *) NULL); - return TCL_ERROR; - } - myaddr = argv[a]; - } else if (strcmp(arg, "-myport") == 0) { - a++; - if (a >= argc) { - Tcl_AppendResult(interp, - "no argument given for -myport option", - (char *) NULL); - return TCL_ERROR; - } - if (TclSockGetPort(interp, argv[a], "tcp", &myport) - != TCL_OK) { - return TCL_ERROR; - } - } else if (strcmp(arg, "-async") == 0) { - if (server == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", - (char *) NULL); - return TCL_ERROR; - } - async = 1; - } else { - Tcl_AppendResult(interp, "bad option \"", arg, - "\", must be -async, -myaddr, -myport, or -server", - (char *) NULL); - return TCL_ERROR; - } - } else { - break; - } - } - if (server) { - host = myaddr; /* NULL implies INADDR_ANY */ - if (myport != 0) { - Tcl_AppendResult(interp, "Option -myport is not valid for servers", - NULL); - return TCL_ERROR; - } - } else if (a < argc) { - host = argv[a]; - a++; - } else { -wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args: should be either:\n", - argv[0], - " ?-myaddr addr? ?-myport myport? ?-async? host port\n", - argv[0], - " -server command ?-myaddr addr? port", - (char *) NULL); - return TCL_ERROR; - } - - if (a == argc-1) { - if (TclSockGetPort(interp, argv[a], "tcp", &port) != TCL_OK) { - return TCL_ERROR; - } - } else { - goto wrongNumArgs; - } - - if (server) { - acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) - sizeof(AcceptCallback)); - copyScript = ckalloc((unsigned) strlen(script) + 1); - strcpy(copyScript, script); - acceptCallbackPtr->script = copyScript; - acceptCallbackPtr->interp = interp; - chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, - (ClientData) acceptCallbackPtr); - if (chan == (Tcl_Channel) NULL) { - ckfree(copyScript); - ckfree((char *) acceptCallbackPtr); - return TCL_ERROR; - } - - /* - * Register with the interpreter to let us know when the - * interpreter is deleted (by having the callback set the - * acceptCallbackPtr->interp field to NULL). This is to - * avoid trying to eval the script in a deleted interpreter. - */ - - RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); - - /* - * Register a close callback. This callback will inform the - * interpreter (if it still exists) that this channel does not - * need to be informed when the interpreter is deleted. - */ - - Tcl_CreateCloseHandler(chan, TcpServerCloseProc, - (ClientData) acceptCallbackPtr); - } else { - chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - } - Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); - - return TCL_OK; -} diff --git a/cde/programs/dtdocbook/tcl/tclIOSock.c b/cde/programs/dtdocbook/tcl/tclIOSock.c deleted file mode 100644 index bf43356f..00000000 --- a/cde/programs/dtdocbook/tcl/tclIOSock.c +++ /dev/null @@ -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 *) ¤t, &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 *) ¤t, &len); - if (current < size) { - len = sizeof(int); - setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *) &size, len); - } - return TCL_OK; -} diff --git a/cde/programs/dtdocbook/tcl/tclIOUtil.c b/cde/programs/dtdocbook/tcl/tclIOUtil.c deleted file mode 100644 index 1a1cb9c2..00000000 --- a/cde/programs/dtdocbook/tcl/tclIOUtil.c +++ /dev/null @@ -1,1320 +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: tclIOUtil.c /main/3 1996/10/03 17:17:59 drk $ */ -/* - * tclIOUtil.c -- - * - * This file contains a collection of utility procedures that - * are shared by the platform specific IO drivers. - * - * Parts of this file are based on code contributed by Karl - * Lehenbauer, Mark Diekhans and Peter da Silva. - * - * 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: @(#) tclIOUtil.c 1.122 96/04/02 18:46:40 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * A linked list of the following structures is used to keep track - * of child processes that have been detached but haven't exited - * yet, so we can make sure that they're properly "reaped" (officially - * waited for) and don't lie around as zombies cluttering the - * system. - */ - -typedef struct Detached { - pid_t pid; /* Id of process that's been detached - * but isn't known to have exited. */ - struct Detached *nextPtr; /* Next in list of all detached - * processes. */ -} Detached; - -static Detached *detList = NULL; /* List of all detached proceses. */ - -/* - * Declarations for local procedures defined in this file: - */ - -static Tcl_File FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, - char *spec, int atOk, char *arg, int flags, - char *nextArg, int *skipPtr, int *closePtr)); - -/* - *---------------------------------------------------------------------- - * - * FileForRedirect -- - * - * This procedure does much of the work of parsing redirection - * operators. It handles "@" if specified and allowed, and a file - * name, and opens the file if necessary. - * - * Results: - * The return value is the descriptor number for the file. If an - * error occurs then NULL is returned and an error message is left - * in interp->result. Several arguments are side-effected; see - * the argument list below for details. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static Tcl_File -FileForRedirect( - Tcl_Interp *interp, /* Intepreter to use for error - * reporting. */ - char *spec, /* Points to character just after - * redirection character. */ - int atOk, /* Non-zero means '@' notation is - * OK, zero means it isn't. */ - char *arg, /* Pointer to entire argument - * containing spec: used for error - * reporting. */ - int flags, /* Flags to use for opening file. */ - char *nextArg, /* Next argument in argc/argv - * array, if needed for file name. - * May be NULL. */ - int *skipPtr, /* This value is incremented if - * nextArg is used for redirection - * spec. */ - int *closePtr /* This value is set to 1 if the file - * that's returned must be closed, 0 - * if it was specified with "@" so - * it must be left open. */ -) -{ - int writing = (flags & O_WRONLY); - Tcl_Channel chan; - Tcl_File file; - - if (atOk && (*spec == '@')) { - spec++; - if (*spec == 0) { - spec = nextArg; - if (spec == NULL) { - goto badLastArg; - } - *skipPtr += 1; - } - chan = Tcl_GetChannel(interp, spec, NULL); - if (chan == (Tcl_Channel) NULL) { - return NULL; - } - *closePtr = 0; - file = Tcl_GetChannelFile(chan, writing ? TCL_WRITABLE : TCL_READABLE); - if (file == NULL) { - Tcl_AppendResult(interp, - "channel \"", - Tcl_GetChannelName(chan), - "\" wasn't opened for ", - writing ? "writing" : "reading", (char *) NULL); - return NULL; - } - if (writing) { - - /* - * Be sure to flush output to the file, so that anything - * written by the child appears after stuff we've already - * written. - */ - - Tcl_Flush(chan); - } - } else { - Tcl_DString buffer; - char *name; - - if (*spec == 0) { - spec = nextArg; - if (spec == NULL) { - goto badLastArg; - } - *skipPtr += 1; - } - name = Tcl_TranslateFileName(interp, spec, &buffer); - if (name) { - file = TclOpenFile(name, flags); - } else { - file = NULL; - } - Tcl_DStringFree(&buffer); - if (file == NULL) { - Tcl_AppendResult(interp, "couldn't ", - (writing) ? "write" : "read", " file \"", spec, "\": ", - Tcl_PosixError(interp), (char *) NULL); - return NULL; - } - *closePtr = 1; - } - return file; - - badLastArg: - Tcl_AppendResult(interp, "can't specify \"", arg, - "\" as last word in command", (char *) NULL); - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetOpenMode -- - * - * Description: - * Computes a POSIX mode mask for opening a file, from a given string, - * and also sets a flag to indicate whether the caller should seek to - * EOF after opening the file. - * - * Results: - * On success, returns mode to pass to "open". If an error occurs, the - * returns -1 and if interp is not NULL, sets interp->result to an - * error message. - * - * Side effects: - * Sets the integer referenced by seekFlagPtr to 1 to tell the caller - * to seek to EOF after opening the file. - * - * Special note: - * This code is based on a prototype implementation contributed - * by Mark Diekhans. - * - *---------------------------------------------------------------------- - */ - -int -TclGetOpenMode( - Tcl_Interp *interp, /* Interpreter to use for error - * reporting - may be NULL. */ - char *string, /* Mode string, e.g. "r+" or - * "RDONLY CREAT". */ - int *seekFlagPtr /* Set this to 1 if the caller - * should seek to EOF during the - * opening of the file. */ -) -{ - int mode, modeArgc, c, i, gotRW; - char **modeArgv, *flag; -#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) - - /* - * Check for the simpler fopen-like access modes (e.g. "r"). They - * are distinguished from the POSIX access modes by the presence - * of a lower-case first letter. - */ - - *seekFlagPtr = 0; - mode = 0; - if (islower(UCHAR(string[0]))) { - switch (string[0]) { - case 'r': - mode = O_RDONLY; - break; - case 'w': - mode = O_WRONLY|O_CREAT|O_TRUNC; - break; - case 'a': - mode = O_WRONLY|O_CREAT; - *seekFlagPtr = 1; - break; - default: - error: - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "illegal access mode \"", string, "\"", - (char *) NULL); - } - return -1; - } - if (string[1] == '+') { - mode &= ~(O_RDONLY|O_WRONLY); - mode |= O_RDWR; - if (string[2] != 0) { - goto error; - } - } else if (string[1] != 0) { - goto error; - } - return mode; - } - - /* - * The access modes are specified using a list of POSIX modes - * such as O_CREAT. - * - * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when - * a NULL interpreter is passed in. - */ - - if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AddErrorInfo(interp, - "\n while processing open access modes \""); - Tcl_AddErrorInfo(interp, string); - Tcl_AddErrorInfo(interp, "\""); - } - return -1; - } - - gotRW = 0; - for (i = 0; i < modeArgc; i++) { - flag = modeArgv[i]; - c = flag[0]; - if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { - mode = (mode & ~RW_MODES) | O_RDONLY; - gotRW = 1; - } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { - mode = (mode & ~RW_MODES) | O_WRONLY; - gotRW = 1; - } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { - mode = (mode & ~RW_MODES) | O_RDWR; - gotRW = 1; - } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { - mode |= O_APPEND; - *seekFlagPtr = 1; - } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { - mode |= O_CREAT; - } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { - mode |= O_EXCL; - } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { -#ifdef O_NOCTTY - mode |= O_NOCTTY; -#else - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", (char *) NULL); - } - ckfree((char *) modeArgv); - return -1; -#endif - } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { -#if defined(O_NDELAY) || defined(O_NONBLOCK) -# ifdef O_NONBLOCK - mode |= O_NONBLOCK; -# else - mode |= O_NDELAY; -# endif -#else - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", (char *) NULL); - } - ckfree((char *) modeArgv); - return -1; -#endif - } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { - mode |= O_TRUNC; - } else { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "invalid access mode \"", flag, - "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT", - " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); - } - ckfree((char *) modeArgv); - return -1; - } - } - ckfree((char *) modeArgv); - if (!gotRW) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode must include either", - " RDONLY, WRONLY, or RDWR", (char *) NULL); - } - return -1; - } - return mode; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalFile -- - * - * Read in a file and process the entire file as one gigantic - * Tcl command. - * - * Results: - * A standard Tcl result, which is either the result of executing - * the file or an error indicating why the file couldn't be read. - * - * Side effects: - * Depends on the commands in the file. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_EvalFile( - Tcl_Interp *interp, /* Interpreter in which to process file. */ - char *fileName /* Name of file to process. Tilde-substitution - * will be performed on this name. */ -) -{ - int result; - struct stat statBuf; - char *cmdBuffer = (char *) NULL; - char *oldScriptFile = (char *) NULL; - Interp *iPtr = (Interp *) interp; - Tcl_DString buffer; - char *nativeName = (char *) NULL; - Tcl_Channel chan = (Tcl_Channel) NULL; - - Tcl_ResetResult(interp); - oldScriptFile = iPtr->scriptFile; - iPtr->scriptFile = fileName; - Tcl_DStringInit(&buffer); - nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (nativeName == NULL) { - goto error; - } - - /* - * If Tcl_TranslateFileName didn't already copy the file name, do it - * here. This way we don't depend on fileName staying constant - * throughout the execution of the script (e.g., what if it happens - * to point to a Tcl variable that the script could change?). - */ - - if (nativeName != Tcl_DStringValue(&buffer)) { - Tcl_DStringSetLength(&buffer, 0); - Tcl_DStringAppend(&buffer, nativeName, -1); - nativeName = Tcl_DStringValue(&buffer); - } - if (stat(nativeName, &statBuf) == -1) { - Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", fileName, - "\": ", Tcl_PosixError(interp), (char *) NULL); - goto error; - } - chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644); - if (chan == (Tcl_Channel) NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", fileName, - "\": ", Tcl_PosixError(interp), (char *) NULL); - goto error; - } - cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1); - result = Tcl_Read(chan, cmdBuffer, statBuf.st_size); - if (result < 0) { - Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", fileName, - "\": ", Tcl_PosixError(interp), (char *) NULL); - goto error; - } - cmdBuffer[result] = 0; - if (Tcl_Close(interp, chan) != TCL_OK) { - goto error; - } - - result = Tcl_Eval(interp, cmdBuffer); - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } else if (result == TCL_ERROR) { - char msg[200]; - - /* - * Record information telling where the error occurred. - */ - - sprintf(msg, "\n (file \"%.150s\" line %d)", fileName, - interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - iPtr->scriptFile = oldScriptFile; - ckfree(cmdBuffer); - Tcl_DStringFree(&buffer); - return result; - -error: - if (cmdBuffer != (char *) NULL) { - ckfree(cmdBuffer); - } - iPtr->scriptFile = oldScriptFile; - Tcl_DStringFree(&buffer); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DetachPids -- - * - * This procedure is called to indicate that one or more child - * processes have been placed in background and will never be - * waited for; they should eventually be reaped by - * Tcl_ReapDetachedProcs. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DetachPids( - int numPids, /* Number of pids to detach: gives size - * of array pointed to by pidPtr. */ - pid_t *pidPtr /* Array of pids to detach. */ -) -{ - Detached *detPtr; - int i; - - for (i = 0; i < numPids; i++) { - detPtr = (Detached *) ckalloc(sizeof(Detached)); - detPtr->pid = pidPtr[i]; - detPtr->nextPtr = detList; - detList = detPtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ReapDetachedProcs -- - * - * This procedure checks to see if any detached processes have - * exited and, if so, it "reaps" them by officially waiting on - * them. It should be called "occasionally" to make sure that - * all detached processes are eventually reaped. - * - * Results: - * None. - * - * Side effects: - * Processes are waited on, so that they can be reaped by the - * system. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_ReapDetachedProcs(void) -{ - Detached *detPtr; - Detached *nextPtr, *prevPtr; - int status; - pid_t pid; - - for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { - pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); - if ((pid == 0) || ((pid == (pid_t)-1) && (errno != ECHILD))) { - prevPtr = detPtr; - detPtr = detPtr->nextPtr; - continue; - } - nextPtr = detPtr->nextPtr; - if (prevPtr == NULL) { - detList = detPtr->nextPtr; - } else { - prevPtr->nextPtr = detPtr->nextPtr; - } - ckfree((char *) detPtr); - detPtr = nextPtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclCleanupChildren -- - * - * This is a utility procedure used to wait for child processes - * to exit, record information about abnormal exits, and then - * collect any stderr output generated by them. - * - * Results: - * The return value is a standard Tcl result. If anything at - * weird happened with the child processes, TCL_ERROR is returned - * and a message is left in interp->result. - * - * Side effects: - * If the last character of interp->result is a newline, then it - * is removed unless keepNewline is non-zero. File errorId gets - * closed, and pidPtr is freed back to the storage allocator. - * - *---------------------------------------------------------------------- - */ - -int -TclCleanupChildren( - Tcl_Interp *interp, /* Used for error messages. */ - int numPids, /* Number of entries in pidPtr array. */ - pid_t *pidPtr, /* Array of process ids of children. */ - Tcl_Channel errorChan /* Channel for file containing stderr output - * from pipeline. NULL means there isn't any - * stderr output. */ -) -{ - int result = TCL_OK; - pid_t pid; - int i, abnormalExit, anyErrorInfo; - WAIT_STATUS_TYPE waitStatus; - char *msg; - - abnormalExit = 0; - for (i = 0; i < numPids; i++) { - pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); - if (pid == (pid_t)-1) { - result = TCL_ERROR; - if (interp != (Tcl_Interp *) NULL) { - msg = Tcl_PosixError(interp); - if (errno == ECHILD) { - /* - * This changeup in message suggested by Mark Diekhans - * to remind people that ECHILD errors can occur on - * some systems if SIGCHLD isn't in its default state. - */ - - msg = - "child process lost (is SIGCHLD ignored or trapped?)"; - } - Tcl_AppendResult(interp, "error waiting for process to exit: ", - msg, (char *) NULL); - } - continue; - } - - /* - * Create error messages for unusual process exits. An - * extra newline gets appended to each error message, but - * it gets removed below (in the same fashion that an - * extra newline in the command's output is removed). - */ - - if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { - char msg1[20], msg2[20]; - - result = TCL_ERROR; - sprintf(msg1, "%ld", (long)pid); - if (WIFEXITED(waitStatus)) { - if (interp != (Tcl_Interp *) NULL) { - sprintf(msg2, "%d", WEXITSTATUS(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, - (char *) NULL); - } - abnormalExit = 1; - } else if (WIFSIGNALED(waitStatus)) { - if (interp != (Tcl_Interp *) NULL) { - char *p; - - p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus))); - Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, - Tcl_SignalId((int) (WTERMSIG(waitStatus))), p, - (char *) NULL); - Tcl_AppendResult(interp, "child killed: ", p, "\n", - (char *) NULL); - } - } else if (WIFSTOPPED(waitStatus)) { - if (interp != (Tcl_Interp *) NULL) { - char *p; - - p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus))); - Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, - Tcl_SignalId((int) (WSTOPSIG(waitStatus))), - p, (char *) NULL); - Tcl_AppendResult(interp, "child suspended: ", p, "\n", - (char *) NULL); - } - } else { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "child wait status didn't make sense\n", - (char *) NULL); - } - } - } - } - - /* - * Read the standard error file. If there's anything there, - * then return an error and add the file's contents to the result - * string. - */ - - anyErrorInfo = 0; - if (errorChan != NULL) { - - /* - * Make sure we start at the beginning of the file. - */ - - Tcl_Seek(errorChan, 0L, SEEK_SET); - - if (interp != (Tcl_Interp *) NULL) { - while (1) { -#define BUFFER_SIZE 1000 - char buffer[BUFFER_SIZE+1]; - int count; - - count = Tcl_Read(errorChan, buffer, BUFFER_SIZE); - if (count == 0) { - break; - } - result = TCL_ERROR; - if (count < 0) { - Tcl_AppendResult(interp, - "error reading stderr output file: ", - Tcl_PosixError(interp), (char *) NULL); - break; /* out of the "while (1)" loop. */ - } - buffer[count] = 0; - Tcl_AppendResult(interp, buffer, (char *) NULL); - anyErrorInfo = 1; - } - } - - Tcl_Close(NULL, errorChan); - } - - /* - * If a child exited abnormally but didn't output any error information - * at all, generate an error message here. - */ - - if (abnormalExit && !anyErrorInfo && (interp != (Tcl_Interp *) NULL)) { - Tcl_AppendResult(interp, "child process exited abnormally", - (char *) NULL); - } - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCreatePipeline -- - * - * Given an argc/argv array, instantiate a pipeline of processes - * as described by the argv. - * - * Results: - * The return value is a count of the number of new processes - * created, or -1 if an error occurred while creating the pipeline. - * *pidArrayPtr is filled in with the address of a dynamically - * allocated array giving the ids of all of the processes. It - * is up to the caller to free this array when it isn't needed - * anymore. If inPipePtr is non-NULL, *inPipePtr is filled in - * with the file id for the input pipe for the pipeline (if any): - * the caller must eventually close this file. If outPipePtr - * isn't NULL, then *outPipePtr is filled in with the file id - * for the output pipe from the pipeline: the caller must close - * this file. If errFilePtr isn't NULL, then *errFilePtr is filled - * with a file id that may be used to read error output after the - * pipeline completes. - * - * Side effects: - * Processes and pipes are created. - * - *---------------------------------------------------------------------- - */ - -int -TclCreatePipeline( - Tcl_Interp *interp, /* Interpreter to use for error reporting. */ - 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. */ - pid_t **pidArrayPtr, /* Word at *pidArrayPtr gets filled in with - * address of array of pids for processes - * in pipeline (first pid is first process - * in pipeline). */ - Tcl_File *inPipePtr, /* If non-NULL, input to the pipeline comes - * from a pipe (unless overridden by - * redirection in the command). The file - * id with which to write to this pipe is - * stored at *inPipePtr. NULL means command - * specified its own input source. */ - Tcl_File *outPipePtr, /* If non-NULL, output to the pipeline goes - * to a pipe, unless overriden by redirection - * in the command. The file id with which to - * read frome this pipe is stored at - * *outPipePtr. NULL means command specified - * its own output sink. */ - Tcl_File *errFilePtr /* If non-NULL, all stderr output from the - * pipeline will go to a temporary file - * created here, and a descriptor to read - * the file will be left at *errFilePtr. - * The file will be removed already, so - * closing this descriptor will be the end - * of the file. If this is NULL, then - * all stderr output goes to our stderr. - * If the pipeline specifies redirection - * then the file will still be created - * but it will never get any data. */ -) -{ -#if defined( MAC_TCL ) - Tcl_AppendResult(interp, - "command pipelines not supported on Macintosh OS", NULL); - return -1; -#else /* !MAC_TCL */ - pid_t *pidPtr = NULL; /* Points to malloc-ed array holding all - * the pids of child processes. */ - int numPids = 0; /* Actual number of processes that exist - * at *pidPtr right now. */ - int cmdCount; /* Count of number of distinct commands - * found in argc/argv. */ - char *input = NULL; /* If non-null, then this points to a - * string containing input data (specified - * via <<) to be piped to the first process - * in the pipeline. */ - Tcl_File inputFile = NULL; - /* If != NULL, gives file to use as input for - * first process in pipeline (specified via < - * or <@). */ - int closeInput = 0; /* If non-zero, then must close inputId - * when cleaning up (zero means the file needs - * to stay open for some other reason). */ - Tcl_File outputFile = NULL; - /* Writable file for output from last command - * in pipeline (could be file or pipe). NULL - * means use stdout. */ - int closeOutput = 0; /* Non-zero means must close outputId when - * cleaning up (similar to closeInput). */ - Tcl_File errorFile = NULL; - /* Writable file for error output from all - * commands in pipeline. NULL means use - * stderr. */ - int closeError = 0; /* Non-zero means must close errorId when - * cleaning up. */ - int skip; /* Number of arguments to skip (because they - * specify redirection). */ - int lastBar; - int i, j; - char *p; - int hasPipes = TclHasPipes(); - char finalOut[L_tmpnam]; - char intIn[L_tmpnam]; - - finalOut[0] = '\0'; - intIn[0] = '\0'; - - if (inPipePtr != NULL) { - *inPipePtr = NULL; - } - if (outPipePtr != NULL) { - *outPipePtr = NULL; - } - if (errFilePtr != NULL) { - *errFilePtr = NULL; - } - - /* - * First, scan through all the arguments to figure out the structure - * of the pipeline. Process all of the input and output redirection - * arguments and remove them from the argument list in the pipeline. - * Count the number of distinct processes (it's the number of "|" - * arguments plus one) but don't remove the "|" arguments. - */ - - cmdCount = 1; - lastBar = -1; - for (i = 0; i < argc; i++) { - if ((argv[i][0] == '|') && (((argv[i][1] == 0)) - || ((argv[i][1] == '&') && (argv[i][2] == 0)))) { - if ((i == (lastBar+1)) || (i == (argc-1))) { - interp->result = "illegal use of | or |& in command"; - return -1; - } - lastBar = i; - cmdCount++; - continue; - } else if (argv[i][0] == '<') { - if ((inputFile != NULL) && closeInput) { - TclCloseFile(inputFile); - } - inputFile = NULL; - skip = 1; - if (argv[i][1] == '<') { - input = argv[i]+2; - if (*input == 0) { - input = argv[i+1]; - if (input == 0) { - Tcl_AppendResult(interp, "can't specify \"", argv[i], - "\" as last word in command", (char *) NULL); - goto error; - } - skip = 2; - } - } else { - input = 0; - inputFile = FileForRedirect(interp, argv[i]+1, 1, argv[i], - O_RDONLY, argv[i+1], &skip, &closeInput); - if (inputFile == NULL) { - goto error; - } - - /* When Win32s dies out, this code can be removed */ - if (!hasPipes) { - if (!closeInput) { - Tcl_AppendResult(interp, "redirection with '@'", - " notation is not supported on this system", - (char *) NULL); - goto error; - } - strcpy(intIn, skip == 1 ? argv[i]+1 : argv[i+1]); - } - } - } else if (argv[i][0] == '>') { - int append, useForStdErr, useForStdOut, mustClose, atOk, flags; - Tcl_File file; - - skip = atOk = 1; - append = useForStdErr = 0; - useForStdOut = 1; - if (argv[i][1] == '>') { - p = argv[i] + 2; - append = 1; - atOk = 0; - flags = O_WRONLY|O_CREAT; - } else { - p = argv[i] + 1; - flags = O_WRONLY|O_CREAT|O_TRUNC; - } - if (*p == '&') { - useForStdErr = 1; - p++; - } - file = FileForRedirect(interp, p, atOk, argv[i], flags, argv[i+1], - &skip, &mustClose); - if (file == NULL) { - goto error; - } - - /* When Win32s dies out, this code can be removed */ - if (!hasPipes) { - if (!mustClose) { - Tcl_AppendResult(interp, "redirection with '@'", - " notation is not supported on this system", - (char *) NULL); - goto error; - } - strcpy(finalOut, skip == 1 ? p : argv[i+1]); - } - - if (hasPipes && append) { - TclSeekFile(file, 0L, 2); - } - - /* - * Got the file descriptor. Now use it for standard output, - * standard error, or both, depending on the redirection. - */ - - if (useForStdOut) { - if ((outputFile != NULL) && closeOutput) { - TclCloseFile(outputFile); - } - outputFile = file; - closeOutput = mustClose; - } - if (useForStdErr) { - if ((errorFile != NULL) && closeError) { - TclCloseFile(errorFile); - } - errorFile = file; - closeError = (useForStdOut) ? 0 : mustClose; - } - } else if ((argv[i][0] == '2') && (argv[i][1] == '>')) { - int append, atOk, flags; - - if ((errorFile != NULL) && closeError) { - TclCloseFile(errorFile); - } - skip = 1; - p = argv[i] + 2; - if (*p == '>') { - p++; - append = 1; - atOk = 0; - flags = O_WRONLY|O_CREAT; - } else { - append = 0; - atOk = 1; - flags = O_WRONLY|O_CREAT|O_TRUNC; - } - errorFile = FileForRedirect(interp, p, atOk, argv[i], flags, - argv[i+1], &skip, &closeError); - if (errorFile == NULL) { - goto error; - } - if (hasPipes && append) { - TclSeekFile(errorFile, 0L, 2); - } - } else { - continue; - } - for (j = i+skip; j < argc; j++) { - argv[j-skip] = argv[j]; - } - argc -= skip; - i -= 1; /* Process next arg from same position. */ - } - if (argc == 0) { - interp->result = "didn't specify command to execute"; - return -1; - } - - if ((hasPipes && inputFile == NULL) || (!hasPipes && intIn[0] == '\0')) { - if (input != NULL) { - - /* - * The input for the first process is immediate data coming from - * Tcl. Create a temporary file for it and put the data into the - * file. - */ - - inputFile = TclCreateTempFile(input); - closeInput = 1; - if (inputFile == NULL) { - Tcl_AppendResult(interp, - "couldn't create input file for command: ", - Tcl_PosixError(interp), (char *) NULL); - goto error; - } - } else if (inPipePtr != NULL) { - Tcl_File inPipe, outPipe; - /* - * The input for the first process in the pipeline is to - * come from a pipe that can be written from this end. - */ - - if (!hasPipes || TclCreatePipe(&inPipe, &outPipe) == 0) { - Tcl_AppendResult(interp, - "couldn't create input pipe for command: ", - Tcl_PosixError(interp), (char *) NULL); - goto error; - } - inputFile = inPipe; - closeInput = 1; - *inPipePtr = outPipe; - } - } - - /* - * Set up a pipe to receive output from the pipeline, if no other - * output sink has been specified. - */ - - if ((outputFile == NULL) && (outPipePtr != NULL)) { - if (!hasPipes) { - tmpnam(finalOut); - } else { - Tcl_File inPipe, outPipe; - if (TclCreatePipe(&inPipe, &outPipe) == 0) { - Tcl_AppendResult(interp, - "couldn't create output pipe for command: ", - Tcl_PosixError(interp), (char *) NULL); - goto error; - } - outputFile = outPipe; - closeOutput = 1; - *outPipePtr = inPipe; - } - } - - /* - * Set up the standard error output sink for the pipeline, if - * requested. Use a temporary file which is opened, then deleted. - * Could potentially just use pipe, but if it filled up it could - * cause the pipeline to deadlock: we'd be waiting for processes - * to complete before reading stderr, and processes couldn't complete - * because stderr was backed up. - */ - - if (errFilePtr && !errorFile) { - *errFilePtr = TclCreateTempFile(NULL); - if (*errFilePtr == NULL) { - Tcl_AppendResult(interp, - "couldn't create error file for command: ", - Tcl_PosixError(interp), (char *) NULL); - goto error; - } - errorFile = *errFilePtr; - closeError = 0; - } - - /* - * Scan through the argc array, forking off a process for each - * group of arguments between "|" arguments. - */ - - pidPtr = (pid_t *) ckalloc((unsigned) (cmdCount * sizeof(pid_t))); - Tcl_ReapDetachedProcs(); - - if (TclSpawnPipeline(interp, pidPtr, &numPids, argc, argv, - inputFile, outputFile, errorFile, intIn, finalOut) == 0) { - goto error; - } - *pidArrayPtr = pidPtr; - - /* - * All done. Cleanup open files lying around and then return. - */ - -cleanup: - if ((inputFile != NULL) && closeInput) { - TclCloseFile(inputFile); - } - if ((outputFile != NULL) && closeOutput) { - TclCloseFile(outputFile); - } - if ((errorFile != NULL) && closeError) { - TclCloseFile(errorFile); - } - return numPids; - - /* - * An error occurred. There could have been extra files open, such - * as pipes between children. Clean them all up. Detach any child - * processes that have been created. - */ - -error: - if ((inPipePtr != NULL) && (*inPipePtr != NULL)) { - TclCloseFile(*inPipePtr); - *inPipePtr = NULL; - } - if ((outPipePtr != NULL) && (*outPipePtr != NULL)) { - TclCloseFile(*outPipePtr); - *outPipePtr = NULL; - } - if ((errFilePtr != NULL) && (*errFilePtr != NULL)) { - TclCloseFile(*errFilePtr); - *errFilePtr = NULL; - } - if (pidPtr != NULL) { - for (i = 0; i < numPids; i++) { - if (pidPtr[i] != (pid_t)-1) { - Tcl_DetachPids(1, &pidPtr[i]); - } - } - ckfree((char *) pidPtr); - } - numPids = -1; - goto cleanup; -#endif /* !MAC_TCL */ -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetErrno -- - * - * Gets the current value of the Tcl error code variable. This is - * currently the global variable "errno" but could in the future - * change to something else. - * - * Results: - * The value of the Tcl error code variable. - * - * Side effects: - * None. Note that the value of the Tcl error code variable is - * UNDEFINED if a call to Tcl_SetErrno did not precede this call. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetErrno(void) -{ - return errno; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetErrno -- - * - * Sets the Tcl error code variable to the supplied value. - * - * Results: - * None. - * - * Side effects: - * Modifies the value of the Tcl error code variable. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetErrno( - int err /* The new value. */ -) -{ - errno = err; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_PosixError -- - * - * This procedure is typically called after UNIX kernel calls - * return errors. It stores machine-readable information about - * the error in $errorCode returns an information string for - * the caller's use. - * - * Results: - * The return value is a human-readable string describing the - * error. - * - * Side effects: - * The global variable $errorCode is reset. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_PosixError( - Tcl_Interp *interp /* Interpreter whose $errorCode variable - * is to be changed. */ -) -{ - char *id, *msg; - - msg = Tcl_ErrnoMsg(errno); - id = Tcl_ErrnoId(); - Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); - return msg; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenCommandChannel -- - * - * Opens an I/O channel to one or more subprocesses specified - * by argc and argv. The flags argument determines the - * disposition of the stdio handles. If the TCL_STDIN flag is - * set then the standard input for the first subprocess will - * be tied to the channel: writing to the channel will provide - * input to the subprocess. If TCL_STDIN is not set, then - * standard input for the first subprocess will be the same as - * this application's standard input. If TCL_STDOUT is set then - * standard output from the last subprocess can be read from the - * channel; otherwise it goes to this application's standard - * output. If TCL_STDERR is set, standard error output for all - * subprocesses is returned to the channel and results in an error - * when the channel is closed; otherwise it goes to this - * application's standard error. If TCL_ENFORCE_MODE is not set, - * then argc and argv can redirect the stdio handles to override - * TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it - * is an error for argc and argv to override stdio channels for - * which TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set. - * - * Results: - * A new command channel, or NULL on failure with an error - * message left in interp. - * - * Side effects: - * Creates processes, opens pipes. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_OpenCommandChannel( - Tcl_Interp *interp, /* Interpreter for error reporting. Can - * NOT be NULL. */ - int argc, /* How many arguments. */ - char **argv, /* Array of arguments for command pipe. */ - int flags /* Or'ed combination of TCL_STDIN, TCL_STDOUT, - * TCL_STDERR, and TCL_ENFORCE_MODE. */ -) -{ - Tcl_File *inPipePtr, *outPipePtr, *errFilePtr; - Tcl_File inPipe, outPipe, errFile; - int numPids; - pid_t *pidPtr; - Tcl_Channel channel; - - inPipe = outPipe = errFile = NULL; - - inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL; - outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL; - errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL; - - numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr, - outPipePtr, errFilePtr); - - if (numPids < 0) { - goto error; - } - - /* - * Verify that the pipes that were created satisfy the - * readable/writable constraints. - */ - - if (flags & TCL_ENFORCE_MODE) { - if ((flags & TCL_STDOUT) && (outPipe == NULL)) { - Tcl_AppendResult(interp, "can't read output from command:", - " standard output was redirected", (char *) NULL); - goto error; - } - if ((flags & TCL_STDIN) && (inPipe == NULL)) { - Tcl_AppendResult(interp, "can't write input to command:", - " standard input was redirected", (char *) NULL); - goto error; - } - } - - channel = TclCreateCommandChannel(outPipe, inPipe, errFile, - numPids, pidPtr); - - if (channel == (Tcl_Channel) NULL) { - Tcl_AppendResult(interp, "pipe for command could not be created", - (char *) NULL); - goto error; - } - return channel; - -error: - if (numPids > 0) { - Tcl_DetachPids(numPids, pidPtr); - ckfree((char *) pidPtr); - } - if (inPipe != NULL) { - TclClosePipeFile(inPipe); - } - if (outPipe != NULL) { - TclClosePipeFile(outPipe); - } - if (errFile != NULL) { - TclClosePipeFile(errFile); - } - return NULL; -} diff --git a/cde/programs/dtdocbook/tcl/tclInt.h b/cde/programs/dtdocbook/tcl/tclInt.h deleted file mode 100644 index aad4be70..00000000 --- a/cde/programs/dtdocbook/tcl/tclInt.h +++ /dev/null @@ -1,1101 +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: tclInt.h /main/4 1996/10/04 10:01:56 drk $ */ -/* - * tclInt.h -- - * - * Declarations of things used internally by the Tcl interpreter. - * - * Copyright (c) 1987-1993 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: @(#) tclInt.h 1.200 96/04/11 17:24:12 - */ - -#ifndef _TCLINT -#define _TCLINT - -/* - * Common include files needed by most of the Tcl source files are - * included here, so that system-dependent personalizations for the - * include files only have to be made in once place. This results - * in a few extra includes, but greater modularity. The order of - * the three groups of #includes is important. For example, stdio.h - * is needed by tcl.h, and the _ANSI_ARGS_ declaration in tcl.h is - * needed by stdlib.h in some configurations. - */ - -#include -#include - -#include /* for pid_t */ - -#ifndef _TCL -#include "tcl.h" -#endif -#ifndef _REGEXP -#include "tclRegexp.h" -#endif - -#include -#ifdef NO_LIMITS_H -# include "../compat/limits.h" -#else -# include -#endif -#ifdef NO_STDLIB_H -# include "../compat/stdlib.h" -#else -# include -#endif -#ifdef NO_STRING_H -#include "../compat/string.h" -#else -#include -#endif -#if defined(__STDC__) || defined(HAS_STDARG) -# include -#else -# include -#endif - -/* - *---------------------------------------------------------------- - * Data structures related to variables. These are used primarily - * in tclVar.c - *---------------------------------------------------------------- - */ - -/* - * The following structure defines a variable trace, which is used to - * invoke a specific C procedure whenever certain operations are performed - * on a variable. - */ - -typedef struct VarTrace { - Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given - * by flags are performed on variable. */ - ClientData clientData; /* Argument to pass to proc. */ - int flags; /* What events the trace procedure is - * interested in: OR-ed combination of - * TCL_TRACE_READS, TCL_TRACE_WRITES, and - * TCL_TRACE_UNSETS. */ - struct VarTrace *nextPtr; /* Next in list of traces associated with - * a particular variable. */ -} VarTrace; - -/* - * When a variable trace is active (i.e. its associated procedure is - * executing), one of the following structures is linked into a list - * associated with the variable's interpreter. The information in - * the structure is needed in order for Tcl to behave reasonably - * if traces are deleted while traces are active. - */ - -typedef struct ActiveVarTrace { - struct Var *varPtr; /* Variable that's being traced. */ - struct ActiveVarTrace *nextPtr; - /* Next in list of all active variable - * traces for the interpreter, or NULL - * if no more. */ - VarTrace *nextTracePtr; /* Next trace to check after current - * trace procedure returns; if this - * trace gets deleted, must update pointer - * to avoid using free'd memory. */ -} ActiveVarTrace; - -/* - * The following structure describes an enumerative search in progress on - * an array variable; this are invoked with options to the "array" - * command. - */ - -typedef struct ArraySearch { - int id; /* Integer id used to distinguish among - * multiple concurrent searches for the - * same array. */ - struct Var *varPtr; /* Pointer to array variable that's being - * searched. */ - Tcl_HashSearch search; /* Info kept by the hash module about - * progress through the array. */ - Tcl_HashEntry *nextEntry; /* Non-null means this is the next element - * to be enumerated (it's leftover from - * the Tcl_FirstHashEntry call or from - * an "array anymore" command). NULL - * means must call Tcl_NextHashEntry - * to get value to return. */ - struct ArraySearch *nextPtr;/* Next in list of all active searches - * for this variable, or NULL if this is - * the last one. */ -} ArraySearch; - -/* - * The structure below defines a variable, which associates a string name - * with a string value. Pointers to these structures are kept as the - * values of hash table entries, and the name of each variable is stored - * in the hash entry. - */ - -typedef struct Var { - int valueLength; /* Holds the number of non-null bytes - * actually occupied by the variable's - * current value in value.string (extra - * space is sometimes left for expansion). - * For array and global variables this is - * meaningless. */ - int valueSpace; /* Total number of bytes of space allocated - * at value.string. 0 means there is no - * space allocated. */ - union { - char *string; /* String value of variable, used for scalar - * variables and array elements. Malloc-ed. */ - Tcl_HashTable *tablePtr;/* For array variables, this points to - * information about the hash table used - * to implement the associative array. - * Points to malloc-ed data. */ - struct Var *upvarPtr; /* If this is a global variable being - * referred to in a procedure, or a variable - * created by "upvar", this field points to - * the record for the higher-level variable. */ - } value; - Tcl_HashEntry *hPtr; /* Hash table entry that refers to this - * variable, or NULL if the variable has - * been detached from its hash table (e.g. - * an array is deleted, but some of its - * elements are still referred to in upvars). */ - int refCount; /* Counts number of active uses of this - * variable, not including its main hash - * table entry: 1 for each additional variable - * whose upVarPtr points here, 1 for each - * nested trace active on variable. This - * record can't be deleted until refCount - * becomes 0. */ - VarTrace *tracePtr; /* First in list of all traces set for this - * variable. */ - ArraySearch *searchPtr; /* First in list of all searches active - * for this variable, or NULL if none. */ - int flags; /* Miscellaneous bits of information about - * variable. See below for definitions. */ -} Var; - -/* - * Flag bits for variables: - * - * VAR_ARRAY - 1 means this is an array variable rather - * than a scalar variable. - * VAR_UPVAR - 1 means this variable just contains a - * pointer to another variable that has the - * real value. Variables like this come - * about through the "upvar" and "global" - * commands. - * VAR_UNDEFINED - 1 means that the variable is currently - * undefined. Undefined variables usually - * go away completely, but if an undefined - * variable has a trace on it, or if it is - * a global variable being used by a procedure, - * then it stays around even when undefined. - * VAR_TRACE_ACTIVE - 1 means that trace processing is currently - * underway for a read or write access, so - * new read or write accesses should not cause - * trace procedures to be called and the - * variable can't be deleted. - */ - -#define VAR_ARRAY 1 -#define VAR_UPVAR 2 -#define VAR_UNDEFINED 4 -#define VAR_TRACE_ACTIVE 0x10 - -/* - *---------------------------------------------------------------- - * Data structures related to procedures. These are used primarily - * in tclProc.c - *---------------------------------------------------------------- - */ - -/* - * The structure below defines an argument to a procedure, which - * consists of a name and an (optional) default value. - */ - -typedef struct Arg { - struct Arg *nextPtr; /* Next argument for this procedure, - * or NULL if this is the last argument. */ - char *defValue; /* Pointer to arg's default value, or NULL - * if no default value. */ - char name[4]; /* Name of argument starts here. The name - * is followed by space for the default, - * if there is one. The actual size of this - * field will be as large as necessary to - * hold both name and default value. THIS - * MUST BE THE LAST FIELD IN THE STRUCTURE!! */ -} Arg; - -/* - * The structure below defines a command procedure, which consists of - * a collection of Tcl commands plus information about arguments and - * variables. - */ - -typedef struct Proc { - struct Interp *iPtr; /* Interpreter for which this command - * is defined. */ - int refCount; /* Reference count: 1 if still present - * in command table plus 1 for each call - * to the procedure that is currently - * active. This structure can be freed - * when refCount becomes zero. */ - char *command; /* Command that constitutes the body of - * the procedure (dynamically allocated). */ - Arg *argPtr; /* Pointer to first of procedure's formal - * arguments, or NULL if none. */ -} Proc; - -/* - * The structure below defines a command trace. This is used to allow Tcl - * clients to find out whenever a command is about to be executed. - */ - -typedef struct Trace { - int level; /* Only trace commands at nesting level - * less than or equal to this. */ - Tcl_CmdTraceProc *proc; /* Procedure to call to trace command. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ - struct Trace *nextPtr; /* Next in list of traces for this interp. */ -} Trace; - -/* - * The structure below defines an entry in the assocData hash table which - * is associated with an interpreter. The entry contains a pointer to a - * function to call when the interpreter is deleted, and a pointer to - * a user-defined piece of data. - */ - -typedef struct AssocData { - Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ - ClientData clientData; /* Value to pass to proc. */ -} AssocData; - -/* - * The structure below defines a frame, which is a procedure invocation. - * These structures exist only while procedures are being executed, and - * provide a sort of call stack. - */ - -typedef struct CallFrame { - Tcl_HashTable varTable; /* Hash table containing all of procedure's - * local variables. */ - int level; /* Level of this procedure, for "uplevel" - * purposes (i.e. corresponds to nesting of - * callerVarPtr's, not callerPtr's). 1 means - * outer-most procedure, 0 means top-level. */ - int argc; /* This and argv below describe name and - * arguments for this procedure invocation. */ - char **argv; /* Array of arguments. */ - struct CallFrame *callerPtr; - /* Value of interp->framePtr when this - * procedure was invoked (i.e. next in - * stack of all active procedures). */ - struct CallFrame *callerVarPtr; - /* Value of interp->varFramePtr when this - * procedure was invoked (i.e. determines - * variable scoping within caller; same - * as callerPtr unless an "uplevel" command - * or something equivalent was active in - * the caller). */ -} CallFrame; - -/* - * The structure below defines one history event (a previously-executed - * command that can be re-executed in whole or in part). - */ - -typedef struct { - char *command; /* String containing previously-executed - * command. */ - int bytesAvl; /* Total # of bytes available at *event (not - * all are necessarily in use now). */ -} HistoryEvent; - -/* - *---------------------------------------------------------------- - * Data structures related to history. These are used primarily - * in tclHistory.c - *---------------------------------------------------------------- - */ - -/* - * The structure below defines a pending revision to the most recent - * history event. Changes are linked together into a list and applied - * during the next call to Tcl_RecordHistory. See the comments at the - * beginning of tclHistory.c for information on revisions. - */ - -typedef struct HistoryRev { - int firstIndex; /* Index of the first byte to replace in - * current history event. */ - int lastIndex; /* Index of last byte to replace in - * current history event. */ - int newSize; /* Number of bytes in newBytes. */ - char *newBytes; /* Replacement for the range given by - * firstIndex and lastIndex (malloced). */ - struct HistoryRev *nextPtr; /* Next in chain of revisions to apply, or - * NULL for end of list. */ -} HistoryRev; - -/* - *---------------------------------------------------------------- - * Data structures related to expressions. These are used only in - * tclExpr.c. - *---------------------------------------------------------------- - */ - -/* - * The data structure below defines a math function (e.g. sin or hypot) - * for use in Tcl expressions. - */ - -#define MAX_MATH_ARGS 5 -typedef struct MathFunc { - int numArgs; /* Number of arguments for function. */ - Tcl_ValueType argTypes[MAX_MATH_ARGS]; - /* Acceptable types for each argument. */ - Tcl_MathProc *proc; /* Procedure that implements this function. */ - ClientData clientData; /* Additional argument to pass to the function - * when invoking it. */ -} MathFunc; - -/* - *---------------------------------------------------------------- - * One of the following structures exists for each command in - * an interpreter. The Tcl_Command opaque type actually refers - * to these structures. - *---------------------------------------------------------------- - */ - -typedef struct Command { - Tcl_HashEntry *hPtr; /* Pointer to the hash table entry in - * interp->commandTable that refers to - * this command. Used to get a command's - * name from its Tcl_Command handle. NULL - * means that the hash table entry has - * been removed already (this can happen - * if deleteProc causes the command to be - * deleted or recreated). */ - Tcl_CmdProc *proc; /* Procedure to process command. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ - Tcl_CmdDeleteProc *deleteProc; - /* Procedure to invoke when deleting - * command. */ - ClientData deleteData; /* Arbitrary value to pass to deleteProc - * (usually the same as clientData). */ - int deleted; /* Means that the command is in the process - * of being deleted (its deleteProc is - * currently executing). Any other attempts - * to delete the command should be ignored. */ -} Command; - -/* - *---------------------------------------------------------------- - * This structure defines an interpreter, which is a collection of - * commands plus other state information related to interpreting - * commands, such as variable storage. Primary responsibility for - * this data structure is in tclBasic.c, but almost every Tcl - * source file uses something in here. - *---------------------------------------------------------------- - */ - -typedef struct Interp { - - /* - * Note: the first three fields must match exactly the fields in - * a Tcl_Interp struct (see tcl.h). If you change one, be sure to - * change the other. - */ - - char *result; /* Points to result returned by last - * command. */ - Tcl_FreeProc *freeProc; /* Zero means result is statically allocated. - * TCL_DYNAMIC means result was allocated with - * ckalloc and should be freed with ckfree. - * Other values give address of procedure - * to invoke to free the result. Must be - * freed by Tcl_Eval before executing next - * command. */ - int errorLine; /* When TCL_ERROR is returned, this gives - * the line number within the command where - * the error occurred (1 means first line). */ - Tcl_HashTable commandTable; /* Contains all of the commands currently - * registered in this interpreter. Indexed - * by strings; values have type (Command *). */ - Tcl_HashTable mathFuncTable;/* Contains all of the math functions currently - * defined for the interpreter. Indexed by - * strings (function names); values have - * type (MathFunc *). */ - - /* - * Information related to procedures and variables. See tclProc.c - * and tclvar.c for usage. - */ - - Tcl_HashTable globalTable; /* Contains all global variables for - * interpreter. */ - int numLevels; /* Keeps track of how many nested calls to - * Tcl_Eval are in progress for this - * interpreter. It's used to delay deletion - * of the table until all Tcl_Eval invocations - * are completed. */ - int maxNestingDepth; /* If numLevels exceeds this value then Tcl - * assumes that infinite recursion has - * occurred and it generates an error. */ - CallFrame *framePtr; /* Points to top-most in stack of all nested - * procedure invocations. NULL means there - * are no active procedures. */ - CallFrame *varFramePtr; /* Points to the call frame whose variables - * are currently in use (same as framePtr - * unless an "uplevel" command is being - * executed). NULL means no procedure is - * active or "uplevel 0" is being exec'ed. */ - ActiveVarTrace *activeTracePtr; - /* First in list of active traces for interp, - * or NULL if no active traces. */ - int returnCode; /* Completion code to return if current - * procedure exits with a TCL_RETURN code. */ - char *errorInfo; /* Value to store in errorInfo if returnCode - * is TCL_ERROR. Malloc'ed, may be NULL */ - char *errorCode; /* Value to store in errorCode if returnCode - * is TCL_ERROR. Malloc'ed, may be NULL */ - - /* - * Information related to history: - */ - - int numEvents; /* Number of previously-executed commands - * to retain. */ - HistoryEvent *events; /* Array containing numEvents entries - * (dynamically allocated). */ - int curEvent; /* Index into events of place where current - * (or most recent) command is recorded. */ - int curEventNum; /* Event number associated with the slot - * given by curEvent. */ - HistoryRev *revPtr; /* First in list of pending revisions. */ - char *historyFirst; /* First char. of current command executed - * from history module or NULL if none. */ - int revDisables; /* 0 means history revision OK; > 0 gives - * a count of number of times revision has - * been disabled. */ - char *evalFirst; /* If TCL_RECORD_BOUNDS flag set, Tcl_Eval - * sets this field to point to the first - * char. of text from which the current - * command came. Otherwise Tcl_Eval sets - * this to NULL. */ - char *evalLast; /* Similar to evalFirst, except points to - * last character of current command. */ - - /* - * Information used by Tcl_AppendResult to keep track of partial - * results. See Tcl_AppendResult code for details. - */ - - char *appendResult; /* Storage space for results generated - * by Tcl_AppendResult. Malloc-ed. NULL - * means not yet allocated. */ - int appendAvl; /* Total amount of space available at - * partialResult. */ - int appendUsed; /* Number of non-null bytes currently - * stored at partialResult. */ - - /* - * A cache of compiled regular expressions. See Tcl_RegExpCompile - * in tclUtil.c for details. - */ - -#define NUM_REGEXPS 5 - char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled - * regular expression patterns. NULL - * means that this slot isn't used. - * Malloc-ed. */ - int patLengths[NUM_REGEXPS];/* Number of non-null characters in - * corresponding entry in patterns. - * -1 means entry isn't used. */ - regexp *regexps[NUM_REGEXPS]; - /* Compiled forms of above strings. Also - * malloc-ed, or NULL if not in use yet. */ - - /* - * Information about packages. Used only in tclPkg.c. - */ - - Tcl_HashTable packageTable; /* Describes all of the packages loaded - * in or available to this interpreter. - * Keys are package names, values are - * (Package *) pointers. */ - char *packageUnknown; /* Command to invoke during "package - * require" commands for packages that - * aren't described in packageTable. - * Malloc'ed, may be NULL. */ - - /* - * Information used by Tcl_PrintDouble: - */ - - char pdFormat[10]; /* Format string used by Tcl_PrintDouble. */ - int pdPrec; /* Current precision (used to restore the - * the tcl_precision variable after a bogus - * value has been put into it). */ - - /* - * Miscellaneous information: - */ - - int cmdCount; /* Total number of times a command procedure - * has been called for this interpreter. */ - int noEval; /* Non-zero means no commands should actually - * be executed: just parse only. Used in - * expressions when the result is already - * determined. */ - int evalFlags; /* Flags to control next call to Tcl_Eval. - * Normally zero, but may be set before - * calling Tcl_Eval. See below for valid - * values. */ - char *termPtr; /* Character just after the last one in - * a command. Set by Tcl_Eval before - * returning. */ - char *scriptFile; /* NULL means there is no nested source - * command active; otherwise this points to - * the name of the file being sourced (it's - * not malloc-ed: it points to an argument - * to Tcl_EvalFile. */ - int flags; /* Various flag bits. See below. */ - Trace *tracePtr; /* List of traces for this interpreter. */ - Tcl_HashTable *assocData; /* Hash table for associating data with - * this interpreter. Cleaned up when - * this interpreter is deleted. */ - char resultSpace[TCL_RESULT_SIZE+1]; - /* Static space for storing small results. */ -} Interp; - -/* - * EvalFlag bits for Interp structures: - * - * TCL_BRACKET_TERM 1 means that the current script is terminated by - * a close bracket rather than the end of the string. - * TCL_RECORD_BOUNDS Tells Tcl_Eval to record information in the - * evalFirst and evalLast fields for each command - * executed directly from the string (top-level - * commands and those from command substitution). - * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with - * a code other than TCL_OK or TCL_ERROR; 0 means - * codes other than these should be turned into errors. - */ - -#define TCL_BRACKET_TERM 1 -#define TCL_RECORD_BOUNDS 2 -#define TCL_ALLOW_EXCEPTIONS 4 - -/* - * Flag bits for Interp structures: - * - * DELETED: Non-zero means the interpreter has been deleted: - * don't process any more commands for it, and destroy - * the structure as soon as all nested invocations of - * Tcl_Eval are done. - * ERR_IN_PROGRESS: Non-zero means an error unwind is already in progress. - * Zero means a command proc has been invoked since last - * error occurred. - * ERR_ALREADY_LOGGED: Non-zero means information has already been logged - * in $errorInfo for the current Tcl_Eval instance, - * so Tcl_Eval needn't log it (used to implement the - * "error message log" command). - * ERROR_CODE_SET: Non-zero means that Tcl_SetErrorCode has been - * called to record information for the current - * error. Zero means Tcl_Eval must clear the - * errorCode variable if an error is returned. - * EXPR_INITIALIZED: 1 means initialization specific to expressions has - * been carried out. - */ - -#define DELETED 1 -#define ERR_IN_PROGRESS 2 -#define ERR_ALREADY_LOGGED 4 -#define ERROR_CODE_SET 8 -#define EXPR_INITIALIZED 0x10 - -/* - * Default value for the pdPrec and pdFormat fields of interpreters: - */ - -#define DEFAULT_PD_PREC 6 -#define DEFAULT_PD_FORMAT "%g" - -/* - *---------------------------------------------------------------- - * Data structures related to command parsing. These are used in - * tclParse.c and its clients. - *---------------------------------------------------------------- - */ - -/* - * The following data structure is used by various parsing procedures - * to hold information about where to store the results of parsing - * (e.g. the substituted contents of a quoted argument, or the result - * of a nested command). At any given time, the space available - * for output is fixed, but a procedure may be called to expand the - * space available if the current space runs out. - */ - -typedef struct ParseValue { - char *buffer; /* Address of first character in - * output buffer. */ - char *next; /* Place to store next character in - * output buffer. */ - char *end; /* Address of the last usable character - * in the buffer. */ - void (*expandProc) _ANSI_ARGS_((struct ParseValue *pvPtr, int needed)); - /* Procedure to call when space runs out; - * it will make more space. */ - ClientData clientData; /* Arbitrary information for use of - * expandProc. */ -} ParseValue; - -/* - * A table used to classify input characters to assist in parsing - * Tcl commands. The table should be indexed with a signed character - * using the CHAR_TYPE macro. The character may have a negative - * value. - */ - -extern char tclTypeTable[]; -#define CHAR_TYPE(c) (tclTypeTable+128)[c] - -/* - * Possible values returned by CHAR_TYPE: - * - * TCL_NORMAL - All characters that don't have special significance - * to the Tcl language. - * TCL_SPACE - Character is space, tab, or return. - * TCL_COMMAND_END - Character is newline or null or semicolon or - * close-bracket. - * TCL_QUOTE - Character is a double-quote. - * TCL_OPEN_BRACKET - Character is a "[". - * TCL_OPEN_BRACE - Character is a "{". - * TCL_CLOSE_BRACE - Character is a "}". - * TCL_BACKSLASH - Character is a "\". - * TCL_DOLLAR - Character is a "$". - */ - -#define TCL_NORMAL 0 -#define TCL_SPACE 1 -#define TCL_COMMAND_END 2 -#define TCL_QUOTE 3 -#define TCL_OPEN_BRACKET 4 -#define TCL_OPEN_BRACE 5 -#define TCL_CLOSE_BRACE 6 -#define TCL_BACKSLASH 7 -#define TCL_DOLLAR 8 - -/* - * Maximum number of levels of nesting permitted in Tcl commands (used - * to catch infinite recursion). - */ - -#define MAX_NESTING_DEPTH 1000 - -/* - * The macro below is used to modify a "char" value (e.g. by casting - * it to an unsigned character) so that it can be used safely with - * macros such as isspace. - */ - -#define UCHAR(c) ((unsigned char) (c)) - -/* - * Given a size or address, the macro below "aligns" it to the machine's - * memory unit size (e.g. an 8-byte boundary) so that anything can be - * placed at the aligned address without fear of an alignment error. - */ - -#define TCL_ALIGN(x) ((x + 7) & ~7) - -/* - * For each event source (created with Tcl_CreateEventSource) there - * is a structure of the following type: - */ - -typedef struct TclEventSource { - Tcl_EventSetupProc *setupProc; /* This procedure is called by - * Tcl_DoOneEvent to set up information - * for the wait operation, such as - * files to wait for or maximum - * timeout. */ - Tcl_EventCheckProc *checkProc; /* This procedure is called by - * Tcl_DoOneEvent after its wait - * operation to see what events - * are ready and queue them. */ - ClientData clientData; /* Arbitrary one-word argument to pass - * to setupProc and checkProc. */ - struct TclEventSource *nextPtr; /* Next in list of all event sources - * defined for applicaton. */ -} TclEventSource; - -/* - * The following macros are used to specify the runtime platform - * setting of the tclPlatform variable. - */ - -typedef enum { - TCL_PLATFORM_UNIX, /* Any Unix-like OS. */ - TCL_PLATFORM_MAC, /* MacOS. */ - TCL_PLATFORM_WINDOWS /* Any Microsoft Windows OS. */ -} TclPlatformType; - -/* - *---------------------------------------------------------------- - * Variables shared among Tcl modules but not used by the outside - * world: - *---------------------------------------------------------------- - */ - -extern Tcl_Time tclBlockTime; -extern int tclBlockTimeSet; -extern char * tclExecutableName; -extern TclEventSource * tclFirstEventSourcePtr; -extern Tcl_ChannelType tclFileChannelType; -extern char * tclMemDumpFileName; -extern TclPlatformType tclPlatform; - -/* - *---------------------------------------------------------------- - * Procedures shared among Tcl modules but not used by the outside - * world: - *---------------------------------------------------------------- - */ - -EXTERN void panic(); -EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, - int numPids, pid_t *pidPtr, Tcl_Channel errorChan)); -EXTERN int TclCloseFile _ANSI_ARGS_((Tcl_File file)); -EXTERN char * TclConvertToNative _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_DString *bufferPtr)); -EXTERN char * TclConvertToNetwork _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_DString *bufferPtr)); -EXTERN void TclCopyAndCollapse _ANSI_ARGS_((int count, char *src, - char *dst)); -EXTERN int TclChdir _ANSI_ARGS_((Tcl_Interp *interp, - char *dirName)); -EXTERN void TclClosePipeFile _ANSI_ARGS_((Tcl_File file)); -EXTERN Tcl_Channel TclCreateCommandChannel _ANSI_ARGS_(( - Tcl_File readFile, Tcl_File writeFile, - Tcl_File errorFile, int numPids, pid_t *pidPtr)); -EXTERN int TclCreatePipe _ANSI_ARGS_((Tcl_File *readPipe, - Tcl_File *writePipe)); -EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, pid_t **pidArrayPtr, - Tcl_File *inPipePtr, - Tcl_File *outPipePtr, - Tcl_File *errFilePtr)); -EXTERN Tcl_File TclCreateTempFile _ANSI_ARGS_((char *contents)); -EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, - Tcl_HashTable *tablePtr)); -EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, - char *separators, Tcl_DString *headPtr, - char *tail)); -EXTERN void TclExpandParseValue _ANSI_ARGS_((ParseValue *pvPtr, - int needed)); -EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, - double value)); -EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp, - char *list, char **elementPtr, char **nextPtr, - int *sizePtr, int *bracePtr)); -EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, - char *procName)); -EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr)); -EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN unsigned long TclGetClicks _ANSI_ARGS_((void)); -EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); -EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Channel chan)); -EXTERN int TclGetDate _ANSI_ARGS_((char *p, - unsigned long now, long zone, - unsigned long *timePtr)); -EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type)); -EXTERN char * TclGetEnv _ANSI_ARGS_((char *name)); -EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, - char *string, CallFrame **framePtrPtr)); -EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int *seekFlagPtr)); -EXTERN unsigned long TclGetSeconds _ANSI_ARGS_((void)); -EXTERN void TclGetTime _ANSI_ARGS_((Tcl_Time *time)); -EXTERN int TclGetTimeZone _ANSI_ARGS_((unsigned long time)); -EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name, - Tcl_DString *bufferPtr)); -EXTERN int TclGetListIndex _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int *indexPtr)); -EXTERN int TclGetLoadedPackages _ANSI_ARGS_((Tcl_Interp *interp, - char *targetName)); -EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name, - Tcl_DString *bufferPtr)); -EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName, - Tcl_DString *bufPtr)); -EXTERN int TclHasPipes _ANSI_ARGS_((void)); -EXTERN int TclHasSockets _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int TclIdlePending _ANSI_ARGS_((void)); -EXTERN int TclInterpInit _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); -EXTERN int TclLoadFile _ANSI_ARGS_((Tcl_Interp *interp, - char *fileName, char *sym1, char *sym2, - Tcl_PackageInitProc **proc1Ptr, - Tcl_PackageInitProc **proc2Ptr)); -EXTERN int TclMakeFileTable _ANSI_ARGS_((Tcl_Interp *interp, - int noStdio)); -EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, - char *separators, Tcl_DString *dirPtr, - char *pattern, char *tail)); -EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); -EXTERN Tcl_File TclOpenFile _ANSI_ARGS_((char *fname, int mode)); -EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char **termPtr, ParseValue *pvPtr)); -EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int flags, char **termPtr, - ParseValue *pvPtr)); -EXTERN int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int termChar, int flags, - char **termPtr, ParseValue *pvPtr)); -EXTERN int TclParseWords _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int flags, int maxWords, - char **termPtr, int *argcPtr, char **argv, - ParseValue *pvPtr)); -EXTERN void TclPlatformExit _ANSI_ARGS_((int status)); -EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *name1, char *name2, - int flags)); -EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *cmdInterp, char *cmdName, - Tcl_CmdProc *proc, ClientData clientData)); -EXTERN int TclReadFile _ANSI_ARGS_((Tcl_File file, - int shouldBlock, char *buf, int toRead)); -EXTERN int TclSeekFile _ANSI_ARGS_((Tcl_File file, - int offset, int whence)); -EXTERN int TclServiceIdle _ANSI_ARGS_((void)); -EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *proto, int *portPtr)); -EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, - int size)); -EXTERN int TclSpawnPipeline _ANSI_ARGS_((Tcl_Interp *interp, - pid_t *pidPtr, int *numPids, int argc, char **argv, - Tcl_File inputFile, - Tcl_File outputFile, - Tcl_File errorFile, - char *intIn, char *finalOut)); -EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int TclTestChannelEventCmd _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int argc, char **argv)); -EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); -EXTERN int TclWaitForFile _ANSI_ARGS_((Tcl_File file, - int mask, int timeout)); -EXTERN char * TclWordEnd _ANSI_ARGS_((char *start, int nested, - int *semiPtr)); -EXTERN int TclWriteFile _ANSI_ARGS_((Tcl_File file, - int shouldBlock, char *buf, int toWrite)); - -/* - *---------------------------------------------------------------- - * Command procedures in the generic core: - *---------------------------------------------------------------- - */ - -EXTERN int Tcl_AfterCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_AppendCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ArrayCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_CaseCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_CatchCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_CdCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ClockCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_CloseCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ConcatCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_CpCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_EofCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ErrorCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_EvalCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ExitCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ExprCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_FblockedCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_FileCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_FileEventCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_FlushCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ForeachCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_FormatCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_GetsCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_GlobalCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_HistoryCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_InfoCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_InterpCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_JoinCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LappendCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LindexCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LinsertCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LlengthCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ListCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LoadCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LrangeCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LreplaceCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LsCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LsearchCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LsortCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_MacBeepCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_MacSourceCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_MkdirCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_MvCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_OpenCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_PackageCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_PidCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ProcCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_PutsCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_PwdCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ReadCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_RegexpCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_RegsubCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_RenameCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ReturnCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_RmCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_RmdirCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ScanCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SplitCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SocketCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SourceCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_StringCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SubstCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SwitchCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_TellCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_TimeCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_UnsetCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_UpdateCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_UplevelCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_UpvarCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_VwaitCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int TclUnsupported0Cmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); - -#endif /* _TCLINT */ diff --git a/cde/programs/dtdocbook/tcl/tclInterp.c b/cde/programs/dtdocbook/tcl/tclInterp.c deleted file mode 100644 index 2edc352f..00000000 --- a/cde/programs/dtdocbook/tcl/tclInterp.c +++ /dev/null @@ -1,2434 +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: tclInterp.c /main/3 1998/04/17 11:24:35 mgreess $ */ -/* - * tclInterp.c -- - * - * This file implements the "interp" command which allows creation - * and manipulation of Tcl interpreters from within Tcl scripts. - * - * 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: @(#) tclInterp.c 1.66 96/04/15 17:26:10 - */ - -#include -#include "tclInt.h" -#include "tclPort.h" - -/* - * Counter for how many aliases were created (global) - */ - -static int aliasCounter = 0; - -/* - * - * struct Slave: - * - * Used by the "interp" command to record and find information about slave - * interpreters. Maps from a command name in the master to information about - * a slave interpreter, e.g. what aliases are defined in it. - */ - -typedef struct { - Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ - Tcl_HashEntry *slaveEntry; /* Hash entry in masters slave table for - * this slave interpreter. Used to find - * this record, and used when deleting the - * slave interpreter to delete it from the - * masters table. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Tcl_Command interpCmd; /* Interpreter object command. */ - Tcl_HashTable aliasTable; /* Table which maps from names of commands - * in slave interpreter to struct Alias - * defined below. */ -} Slave; - -/* - * struct Alias: - * - * Stores information about an alias. Is stored in the slave interpreter - * and used by the source command to find the target command in the master - * when the source command is invoked. - */ - -typedef struct { - char *aliasName; /* Name of alias command. */ - char *targetName; /* Name of target command in master interp. */ - Tcl_Interp *targetInterp; /* Master interpreter. */ - int argc; /* Count of additional args to pass. */ - char **argv; /* Actual additional args to pass. */ - Tcl_HashEntry *aliasEntry; /* Entry for the alias hash table in slave. - * This is used by alias deletion to remove - * the alias from the slave interpreter - * alias table. */ - Tcl_HashEntry *targetEntry; /* Entry for target command in master. - * This is used in the master interpreter to - * map back from the target command to aliases - * redirecting to it. Random access to this - * hash table is never required - we are using - * a hash table only for convenience. */ - Tcl_Command slaveCmd; /* Source command in slave interpreter. */ -} Alias; - -/* - * struct Target: - * - * Maps from master interpreter commands back to the source commands in slave - * interpreters. This is needed because aliases can be created between sibling - * interpreters and must be deleted when the target interpreter is deleted. In - * case they would not be deleted the source interpreter would be left with a - * "dangling pointer". One such record is stored in the Master record of the - * master interpreter (in the targetTable hashtable, see below) with the - * master for each alias which directs to a command in the master. These - * records are used to remove the source command for an from a slave if/when - * the master is deleted. - */ - -typedef struct { - Tcl_Command slaveCmd; /* Command for alias in slave interp. */ - Tcl_Interp *slaveInterp; /* Slave Interpreter. */ -} Target; - -/* - * struct Master: - * - * This record is used for three purposes: First, slaveTable (a hashtable) - * maps from names of commands to slave interpreters. This hashtable is - * used to store information about slave interpreters of this interpreter, - * to map over all slaves, etc. The second purpose is to store information - * about all aliases in slaves (or siblings) which direct to target commands - * in this interpreter (using the targetTable hashtable). The third field in - * the record, isSafe, denotes whether the interpreter is safe or not. Safe - * interpreters have restricted functionality, can only create safe slave - * interpreters and can only load safe extensions. - */ - -typedef struct { - Tcl_HashTable slaveTable; /* Hash table for slave interpreters. - * Maps from command names to Slave records. */ - int isSafe; /* Am I a "safe" interpreter? */ - Tcl_HashTable targetTable; /* Hash table for Target Records. Contains - * all Target records which denote aliases - * from slaves or sibling interpreters that - * direct to commands in this interpreter. This - * table is used to remove dangling pointers - * from the slave (or sibling) interpreters - * when this interpreter is deleted. */ -} Master; - -/* - * Prototypes for local static procedures: - */ - -static int AliasCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *currentInterp, int argc, char **argv)); -static void AliasCmdDeleteProc _ANSI_ARGS_(( - ClientData clientData)); -static int AliasHelper _ANSI_ARGS_((Tcl_Interp *curInterp, - Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, - Master *masterPtr, char *aliasName, - char *targetName, int argc, char **argv)); -static int CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)); -static Tcl_Interp *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, - char *slavePath, int safe)); -static int DeleteAlias _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, char *aliasName)); -static int DescribeAlias _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, char *aliasName)); -static int DeleteInterpObject _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)); -static int DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp, - char *path)); -static Tcl_Interp *GetInterp _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, char *path, - Master **masterPtrPtr)); -static int GetTarget _ANSI_ARGS_((Tcl_Interp *interp, char *path, - char *aliasName)); -static void MasterRecordDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); -static int MakeSafe _ANSI_ARGS_((Tcl_Interp *interp)); -static int SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)); -static int SlaveObjectCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static void SlaveObjectDeleteProc _ANSI_ARGS_(( - ClientData clientData)); -static void SlaveRecordDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); - -/* - * These are all the Tcl core commands which are available in a safe - * interpeter: - */ - -static char *TclCommandsToKeep[] = { - "after", "append", "array", - "break", - "case", "catch", "clock", "close", "concat", "continue", - "eof", "error", "eval", "expr", - "fblocked", "fconfigure", "flush", "for", "foreach", "format", - "gets", "global", - "history", - "if", "incr", "info", "interp", - "join", - "lappend", "lindex", "linsert", "list", "llength", "lower", "lrange", - "lreplace", "lsearch", "lsort", - "package", "pid", "proc", "puts", - "read", "regexp", "regsub", "rename", "return", - "scan", "seek", "set", "split", "string", "switch", - "tell", "trace", - "unset", "update", "uplevel", "upvar", - "vwait", - "while", - NULL}; -static int TclCommandsToKeepCt = - (sizeof (TclCommandsToKeep) / sizeof (char *)) -1 ; - -/* - *---------------------------------------------------------------------- - * - * TclPreventAliasLoop -- - * - * When defining an alias or renaming a command, prevent an alias - * loop from being formed. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * If TCL_ERROR is returned, the function also sets interp->result - * to an error message. - * - * NOTE: - * This function is public internal (instead of being static to - * this file) because it is also used from Tcl_RenameCmd. - * - *---------------------------------------------------------------------- - */ - -int -TclPreventAliasLoop( - Tcl_Interp *interp, /* Interp in which to report errors. */ - Tcl_Interp *cmdInterp, /* Interp in which the command is - * being defined. */ - char *cmdName, /* Name of Tcl command we are - * attempting to define. */ - Tcl_CmdProc *proc, /* The command procedure for the - * command being created. */ - ClientData clientData /* The client data associated with the - * command to be created. */ -) -{ - Alias *aliasPtr, *nextAliasPtr; - Tcl_CmdInfo cmdInfo; - - /* - * If we are not creating or renaming an alias, then it is - * always OK to create or rename the command. - */ - - if (proc != AliasCmd) { - return TCL_OK; - } - - /* - * OK, we are dealing with an alias, so traverse the chain of aliases. - * If we encounter the alias we are defining (or renaming to) any in - * the chain then we have a loop. - */ - - aliasPtr = (Alias *) clientData; - nextAliasPtr = aliasPtr; - while (1) { - - /* - * If the target of the next alias in the chain is the same as the - * source alias, we have a loop. - */ - - if ((strcmp(nextAliasPtr->targetName, cmdName) == 0) && - (nextAliasPtr->targetInterp == cmdInterp)) { - Tcl_AppendResult(interp, "cannot define or rename alias \"", - aliasPtr->aliasName, "\": would create a loop", - (char *) NULL); - return TCL_ERROR; - } - - /* - * Otherwise, follow the chain one step further. If the target - * command is undefined then there is no loop. - */ - - if (Tcl_GetCommandInfo(nextAliasPtr->targetInterp, - nextAliasPtr->targetName, &cmdInfo) == 0) { - return TCL_OK; - } - - /* - * See if the target command is an alias - if so, follow the - * loop to its target command. Otherwise we do not have a loop. - */ - - if (cmdInfo.proc != AliasCmd) { - return TCL_OK; - } - nextAliasPtr = (Alias *) cmdInfo.clientData; - } - - /* NOTREACHED */ -} - -/* - *---------------------------------------------------------------------- - * - * MakeSafe -- - * - * Makes its argument interpreter contain only functionality that is - * defined to be part of Safe Tcl. - * - * Results: - * None. - * - * Side effects: - * Removes commands from its argument interpreter. - * - *---------------------------------------------------------------------- - */ - -static int -MakeSafe( - Tcl_Interp *interp /* Interpreter to be made safe. */ -) -{ - char **argv; /* Args for Tcl_Eval. */ - int argc, keep, i, j; /* Loop indices. */ - char *cmdGetGlobalCmds = "info commands"; /* What command to run. */ - char *cmdNoEnv = "unset env"; /* How to get rid of env. */ - Master *masterPtr; /* Master record of interp - * to be made safe. */ - Tcl_Channel chan; /* Channel to remove from - * safe interpreter. */ - - /* - * Below, Tcl_Eval sets interp->result, so we do not. - */ - - Tcl_ResetResult(interp); - if ((Tcl_Eval(interp, cmdGetGlobalCmds) == TCL_ERROR) || - (Tcl_SplitList(interp, interp->result, &argc, &argv) != TCL_OK)) { - return TCL_ERROR; - } - for (i = 0; i < argc; i++) { - for (keep = 0, j = 0; j < TclCommandsToKeepCt; j++) { - if (strcmp(TclCommandsToKeep[j], argv[i]) == 0) { - keep = 1; - break; - } - } - if (keep == 0) { - (void) Tcl_DeleteCommand(interp, argv[i]); - } - } - ckfree((char *) argv); - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("MakeSafe: could not find master record"); - } - masterPtr->isSafe = 1; - if (Tcl_Eval(interp, cmdNoEnv) == TCL_ERROR) { - return TCL_ERROR; - } - - /* - * Remove the standard channels from the interpreter; safe interpreters - * do not ordinarily have access to stdin, stdout and stderr. - */ - - chan = Tcl_GetStdChannel(TCL_STDIN); - if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); - } - chan = Tcl_GetStdChannel(TCL_STDOUT); - if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); - } - chan = Tcl_GetStdChannel(TCL_STDERR); - if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * GetInterp -- - * - * Helper function to find a slave interpreter given a pathname. - * - * Results: - * Returns the slave interpreter known by that name in the calling - * interpreter, or NULL if no interpreter known by that name exists. - * - * Side effects: - * Assigns to the pointer variable passed in, if not NULL. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Interp * -GetInterp( - Tcl_Interp *interp, /* Interp. to start search from. */ - Master *masterPtr, /* Its master record. */ - char *path, /* The path (name) of interp. to be found. */ - Master **masterPtrPtr /* (Return) its master record. */ -) -{ - Tcl_HashEntry *hPtr; /* Search element. */ - Slave *slavePtr; /* Interim slave record. */ - char **argv; /* Split-up path (name) for interp to find. */ - int argc, i; /* Loop indices. */ - Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ - - if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr; - - if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) { - return (Tcl_Interp *) NULL; - } - - for (searchInterp = interp, i = 0; i < argc; i++) { - - hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]); - if (hPtr == (Tcl_HashEntry *) NULL) { - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - searchInterp = slavePtr->slaveInterp; - if (searchInterp == (Tcl_Interp *) NULL) { - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } - masterPtr = (Master *) Tcl_GetAssocData(searchInterp, - "tclMasterRecord", NULL); - if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr; - if (masterPtr == (Master *) NULL) { - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } - } - ckfree((char *) argv); - return searchInterp; -} - -/* - *---------------------------------------------------------------------- - * - * CreateSlave -- - * - * Helper function to do the actual work of creating a slave interp - * and new object command. Also optionally makes the new slave - * interpreter "safe". - * - * Results: - * Returns the new Tcl_Interp * if successful or NULL if not. If failed, - * the result of the invoking interpreter contains an error message. - * - * Side effects: - * Creates a new slave interpreter and a new object command. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Interp * -CreateSlave( - Tcl_Interp *interp, /* Interp. to start search from. */ - char *slavePath, /* Path (name) of slave to create. */ - int safe /* Should we make it "safe"? */ -) -{ - Master *masterPtr; /* Master record. */ - Tcl_Interp *slaveInterp; /* Ptr to slave interpreter. */ - Tcl_Interp *masterInterp; /* Ptr to master interp for slave. */ - Slave *slavePtr; /* Slave record. */ - Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ - int new; /* Indicates whether new entry. */ - int argc; /* Count of elements in slavePath. */ - char **argv; /* Elements in slavePath. */ - char *masterPath; /* Path to its master. */ - - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("CreatSlave: could not find master record"); - } - - if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) { - return (Tcl_Interp *) NULL; - } - - if (argc < 2) { - masterInterp = interp; - if (argc == 1) { - slavePath = argv[0]; - } - } else { - masterPath = Tcl_Merge(argc-1, argv); - masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "interpreter named \"", masterPath, - "\" not found", (char *) NULL); - ckfree((char *) argv); - ckfree((char *) masterPath); - return (Tcl_Interp *) NULL; - } - ckfree((char *) masterPath); - slavePath = argv[argc-1]; - if (!safe) { - safe = masterPtr->isSafe; - } - } - hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new); - if (new == 0) { - Tcl_AppendResult(interp, "interpreter named \"", slavePath, - "\" already exists, cannot create", (char *) NULL); - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } - slaveInterp = Tcl_CreateInterp(); - if (slaveInterp == (Tcl_Interp *) NULL) { - panic("CreateSlave: out of memory while creating a new interpreter"); - } - slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); - slavePtr->masterInterp = masterInterp; - slavePtr->slaveEntry = hPtr; - slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateCommand(masterInterp, slavePath, - SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc); - Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); - (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", - SlaveRecordDeleteProc, (ClientData) slavePtr); - Tcl_SetHashValue(hPtr, (ClientData) slavePtr); - Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - - if (((safe) && (MakeSafe(slaveInterp) == TCL_ERROR)) || - ((!safe) && (Tcl_Init(slaveInterp) == TCL_ERROR))) { - Tcl_ResetResult(interp); - Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *) - NULL, TCL_GLOBAL_ONLY)); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL, - TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - if (slaveInterp->freeProc != NULL) { - interp->result = slaveInterp->result; - interp->freeProc = slaveInterp->freeProc; - slaveInterp->freeProc = 0; - } else { - Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); - } - Tcl_ResetResult(slaveInterp); - (void) Tcl_DeleteCommand(masterInterp, slavePath); - slaveInterp = (Tcl_Interp *) NULL; - } - ckfree((char *) argv); - return slaveInterp; -} - -/* - *---------------------------------------------------------------------- - * - * CreateInterpObject - - * - * Helper function to do the actual work of creating a new interpreter - * and an object command. - * - * Results: - * A Tcl result. - * - * Side effects: - * See user documentation for details. - * - *---------------------------------------------------------------------- - */ - -static int -CreateInterpObject( - Tcl_Interp *interp, /* Invoking interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int safe; /* Create a safe interpreter? */ - Master *masterPtr; /* Master record. */ - int moreFlags; /* Expecting more flag args? */ - char *slavePath; /* Name of slave. */ - char localSlaveName[200]; /* Local area for creating names. */ - int i; /* Loop counter. */ - size_t len; /* Length of option argument. */ - static int interpCounter = 0; /* Unique id for created names. */ - - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("CreateInterpObject: could not find master record"); - } - moreFlags = 1; - slavePath = NULL; - safe = masterPtr->isSafe; - - if (argc < 2 || argc > 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " create ?-safe? ?--? ?path?\"", (char *) NULL); - return TCL_ERROR; - } - for (i = 2; i < argc; i++) { - len = strlen(argv[i]); - if ((argv[i][0] == '-') && (moreFlags != 0)) { - if ((argv[i][1] == 's') && (strncmp(argv[i], "-safe", len) == 0) - && (len > 1)){ - safe = 1; - } else if ((strncmp(argv[i], "--", len) == 0) && (len > 1)) { - moreFlags = 0; - } else { - Tcl_AppendResult(interp, "bad option \"", argv[i], - "\": should be -safe", (char *) NULL); - return TCL_ERROR; - } - } else { - slavePath = argv[i]; - } - } - if (slavePath == (char *) NULL) { - sprintf(localSlaveName, "interp%d", interpCounter); - interpCounter++; - slavePath = localSlaveName; - } - if (CreateSlave(interp, slavePath, safe) != NULL) { - Tcl_AppendResult(interp, slavePath, (char *) NULL); - return TCL_OK; - } else { - /* - * CreateSlave already set interp->result if there was an error, - * so we do not do it here. - */ - return TCL_ERROR; - } -} - -/* - *---------------------------------------------------------------------- - * - * DeleteOneInterpObject -- - * - * Helper function for DeleteInterpObject. It deals with deleting one - * interpreter at a time. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Deletes an interpreter and its interpreter object command. - * - *---------------------------------------------------------------------- - */ - -static int -DeleteOneInterpObject( - Tcl_Interp *interp, /* Interpreter for reporting errors. */ - char *path /* Path of interpreter to delete. */ -) -{ - Master *masterPtr; /* Interim storage for master record.*/ - Slave *slavePtr; /* Interim storage for slave record. */ - Tcl_Interp *masterInterp; /* Master of interp. to delete. */ - Tcl_HashEntry *hPtr; /* Search element. */ - int localArgc; /* Local copy of count of elements in - * path (name) of interp. to delete. */ - char **localArgv; /* Local copy of path. */ - char *slaveName; /* Last component in path. */ - char *masterPath; /* One-before-last component in path.*/ - - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("DeleteInterpObject: could not find master record"); - } - if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) { - Tcl_AppendResult(interp, "bad interpreter path \"", path, - "\"", (char *) NULL); - return TCL_ERROR; - } - if (localArgc < 2) { - masterInterp = interp; - if (localArgc == 0) { - slaveName = ""; - } else { - slaveName = localArgv[0]; - } - } else { - masterPath = Tcl_Merge(localArgc-1, localArgv); - masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "interpreter named \"", masterPath, - "\" not found", (char *) NULL); - ckfree((char *) localArgv); - ckfree((char *) masterPath); - return TCL_ERROR; - } - ckfree((char *) masterPath); - slaveName = localArgv[localArgc-1]; - } - hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName); - if (hPtr == (Tcl_HashEntry *) NULL) { - ckfree((char *) localArgv); - Tcl_AppendResult(interp, "interpreter named \"", path, - "\" not found", (char *) NULL); - return TCL_ERROR; - } - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - slaveName = Tcl_GetCommandName(masterInterp, slavePtr->interpCmd); - if (Tcl_DeleteCommand(masterInterp, slaveName) != 0) { - ckfree((char *) localArgv); - Tcl_AppendResult(interp, "interpreter named \"", path, - "\" not found", (char *) NULL); - return TCL_ERROR; - } - ckfree((char *) localArgv); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteInterpObject -- - * - * Helper function to do the work of deleting zero or more - * interpreters and their interpreter object commands. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Deletes interpreters and their interpreter object command. - * - *---------------------------------------------------------------------- - */ - -static int -DeleteInterpObject( - Tcl_Interp *interp, /* Interpreter start search from. */ - int argc, /* Number of arguments in vector. */ - char **argv /* Contains path to interps to - * delete. */ -) -{ - int i; - - for (i = 2; i < argc; i++) { - if (DeleteOneInterpObject(interp, argv[i]) != TCL_OK) { - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * AliasHelper -- - * - * Helper function to do the work to actually create an alias or - * delete an alias. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * An alias command is created and entered into the alias table - * for the slave interpreter. - * - *---------------------------------------------------------------------- - */ - -static int -AliasHelper( - Tcl_Interp *curInterp, /* Interp that invoked this proc. */ - Tcl_Interp *slaveInterp, /* Interp where alias cmd will live - * or from which alias will be - * deleted. */ - Tcl_Interp *masterInterp, /* Interp where target cmd will be. */ - Master *masterPtr, /* Master record for target interp. */ - char *aliasName, /* Name of alias cmd. */ - char *targetName, /* Name of target cmd. */ - int argc, /* Additional arguments to store */ - char **argv /* with alias. */ -) -{ - Alias *aliasPtr; /* Storage for alias data. */ - Alias *tmpAliasPtr; /* Temp storage for alias to delete. */ - Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ - int i; /* Loop index. */ - int new; /* Is it a new hash entry? */ - Target *targetPtr; /* Maps from target command in master - * to source command in slave. */ - Slave *slavePtr; /* Maps from source command in slave - * to target command in master. */ - - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); - - /* - * Fix it up if there is no slave record. This can happen if someone - * uses "" as the source for an alias. - */ - - if (slavePtr == (Slave *) NULL) { - slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); - slavePtr->masterInterp = (Tcl_Interp *) NULL; - slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; - slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = (Tcl_Command) NULL; - Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); - (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", - SlaveRecordDeleteProc, (ClientData) slavePtr); - } - - if ((targetName == (char *) NULL) || (targetName[0] == '\0')) { - if (argc != 0) { - Tcl_AppendResult(curInterp, "malformed command: should be", - " \"alias ", aliasName, " {}\"", (char *) NULL); - return TCL_ERROR; - } - - return DeleteAlias(curInterp, slaveInterp, aliasName); - } - - aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias)); - aliasPtr->aliasName = (char *) ckalloc((unsigned) strlen(aliasName)+1); - aliasPtr->targetName = (char *) ckalloc((unsigned) strlen(targetName)+1); - strcpy(aliasPtr->aliasName, aliasName); - strcpy(aliasPtr->targetName, targetName); - aliasPtr->targetInterp = masterInterp; - - aliasPtr->argv = (char **) NULL; - aliasPtr->argc = argc; - if (aliasPtr->argc > 0) { - aliasPtr->argv = (char **) ckalloc((unsigned) sizeof(char *) * - aliasPtr->argc); - for (i = 0; i < argc; i++) { - aliasPtr->argv[i] = (char *) ckalloc((unsigned) strlen(argv[i])+1); - strcpy(aliasPtr->argv[i], argv[i]); - } - } - - if (TclPreventAliasLoop(curInterp, slaveInterp, aliasName, AliasCmd, - (ClientData) aliasPtr) != TCL_OK) { - for (i = 0; i < argc; i++) { - ckfree(aliasPtr->argv[i]); - } - if (aliasPtr->argv != (char **) NULL) { - ckfree((char *) aliasPtr->argv); - } - ckfree(aliasPtr->aliasName); - ckfree(aliasPtr->targetName); - ckfree((char *) aliasPtr); - - return TCL_ERROR; - } - - aliasPtr->slaveCmd = Tcl_CreateCommand(slaveInterp, aliasName, AliasCmd, - (ClientData) aliasPtr, AliasCmdDeleteProc); - - /* - * Make an entry in the alias table. If it already exists delete - * the alias command. Then retry. - */ - - do { - hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new); - if (new == 0) { - tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - (void) Tcl_DeleteCommand(slaveInterp, tmpAliasPtr->aliasName); - Tcl_DeleteHashEntry(hPtr); - } - } while (new == 0); - aliasPtr->aliasEntry = hPtr; - Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); - - targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); - targetPtr->slaveCmd = aliasPtr->slaveCmd; - targetPtr->slaveInterp = slaveInterp; - - do { - hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable), - (char *) (intptr_t) aliasCounter, &new); - aliasCounter++; - } while (new == 0); - - Tcl_SetHashValue(hPtr, (ClientData) targetPtr); - - aliasPtr->targetEntry = hPtr; - - curInterp->result = aliasPtr->aliasName; - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SlaveAliasHelper - - * - * Handles the different forms of the "interp alias" command: - * - interp alias slavePath aliasName - * Describes an alias. - * - interp alias slavePath aliasName {} - * Deletes an alias. - * - interp alias slavePath srcCmd masterPath targetCmd args... - * Creates an alias. - * - * Results: - * A Tcl result. - * - * Side effects: - * See user documentation for details. - * - *---------------------------------------------------------------------- - */ - -static int -SlaveAliasHelper( - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Master *masterPtr; /* Master record for current interp. */ - Tcl_Interp *slaveInterp, /* Interpreters used when */ - *masterInterp; /* creating an alias btn siblings. */ - Master *masterMasterPtr; /* Master record for master interp. */ - - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("SlaveAliasHelper: could not find master record"); - } - if (argc < 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " alias slavePath slaveCmd masterPath masterCmd ?args ..?\"", - (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "could not find interpreter \"", - argv[2], "\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 4) { - return DescribeAlias(interp, slaveInterp, argv[3]); - } - if (argc == 5 && strcmp(argv[4], "") == 0) { - return DeleteAlias(interp, slaveInterp, argv[3]); - } - if (argc < 6) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " alias slavePath slaveCmd masterPath masterCmd ?args ..?\"", - (char *) NULL); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, masterPtr, argv[4], &masterMasterPtr); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "could not find interpreter \"", - argv[4], "\"", (char *) NULL); - return TCL_ERROR; - } - return AliasHelper(interp, slaveInterp, masterInterp, masterMasterPtr, - argv[3], argv[5], argc-6, argv+6); -} - -/* - *---------------------------------------------------------------------- - * - * DescribeAlias -- - * - * Sets interp->result to a Tcl list describing the given alias in the - * given interpreter: its target command and the additional arguments - * to prepend to any invocation of the alias. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -DescribeAlias( - Tcl_Interp *interp, /* Interpreter for result and errors. */ - Tcl_Interp *slaveInterp, /* Interpreter defining alias. */ - char *aliasName /* Name of alias to describe. */ -) -{ - Slave *slavePtr; /* Slave record for slave interpreter. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Alias *aliasPtr; /* Structure describing alias. */ - int i; /* Loop variable. */ - - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", - NULL); - if (slavePtr == (Slave *) NULL) { - panic("DescribeAlias: could not find slave record"); - } - hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - return TCL_OK; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - Tcl_AppendResult(interp, aliasPtr->targetName, (char *) NULL); - for (i = 0; i < aliasPtr->argc; i++) { - Tcl_AppendElement(interp, aliasPtr->argv[i]); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteAlias -- - * - * Deletes the given alias from the slave interpreter given. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Deletes the alias from the slave interpreter. - * - *---------------------------------------------------------------------- - */ - -static int -DeleteAlias( - Tcl_Interp *interp, /* Interpreter for result and errors. */ - Tcl_Interp *slaveInterp, /* Interpreter defining alias. */ - char *aliasName /* Name of alias to delete. */ -) -{ - Slave *slavePtr; /* Slave record for slave interpreter. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Alias *aliasPtr; /* Structure describing alias to delete. */ - - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", - NULL); - if (slavePtr == (Slave *) NULL) { - panic("DeleteAlias: could not find slave record"); - } - - /* - * Get the alias from the alias table, determine the current - * true name of the alias (it may have been renamed!) and then - * delete the true command name. The deleteProc on the alias - * command will take care of removing the entry from the alias - * table. - */ - - hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", - (char *) NULL); - return TCL_ERROR; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - aliasName = Tcl_GetCommandName(slaveInterp, aliasPtr->slaveCmd); - - /* - * NOTE: The deleteProc for this command will delete the - * alias from the hash table. The deleteProc will also - * delete the target information from the master interpreter - * target table. - */ - - if (Tcl_DeleteCommand(slaveInterp, aliasName) != 0) { - panic("DeleteAlias: did not find alias to be deleted"); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetInterpPath -- - * - * Sets the result of the asking interpreter to a proper Tcl list - * containing the names of interpreters between the asking and - * target interpreters. The target interpreter must be either the - * same as the asking interpreter or one of its slaves (including - * recursively). - * - * Results: - * TCL_OK if the target interpreter is the same as, or a descendant - * of, the asking interpreter; TCL_ERROR else. This way one can - * distinguish between the case where the asking and target interps - * are the same (an empty list is the result, and TCL_OK is returned) - * and when the target is not a descendant of the asking interpreter - * (in which case the Tcl result is an error message and the function - * returns TCL_ERROR). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetInterpPath( - Tcl_Interp *askingInterp, /* Interpreter to start search from. */ - Tcl_Interp *targetInterp /* Interpreter to find. */ -) -{ - Master *masterPtr; /* Interim storage for Master record. */ - Slave *slavePtr; /* Interim storage for Slave record. */ - - if (targetInterp == askingInterp) { - return TCL_OK; - } - if (targetInterp == (Tcl_Interp *) NULL) { - return TCL_ERROR; - } - slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord", - NULL); - if (slavePtr == (Slave *) NULL) { - return TCL_ERROR; - } - if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) { - /* - * AskingInterp->result was set by recursive call. - */ - return TCL_ERROR; - } - masterPtr = (Master *) Tcl_GetAssocData(slavePtr->masterInterp, - "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_GetInterpPath: could not find master record"); - } - Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&(masterPtr->slaveTable), - slavePtr->slaveEntry)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * GetTarget -- - * - * Sets the result of the invoking interpreter to a path name for - * the target interpreter of an alias in one of the slaves. - * - * Results: - * TCL_OK if the target interpreter of the alias is a slave of the - * invoking interpreter, TCL_ERROR else. - * - * Side effects: - * Sets the result of the invoking interpreter. - * - *---------------------------------------------------------------------- - */ - -static int -GetTarget( - Tcl_Interp *askingInterp, /* Interpreter to start search from. */ - char *path, /* The path of the interp to find. */ - char *aliasName /* The target of this allias. */ -) -{ - Tcl_Interp *slaveInterp; /* Interim storage for slave. */ - Slave *slaveSlavePtr; /* Its Slave record. */ - Master *masterPtr; /* Interim storage for Master record. */ - Tcl_HashEntry *hPtr; /* Search element. */ - Alias *aliasPtr; /* Data describing the alias. */ - - Tcl_ResetResult(askingInterp); - - masterPtr = (Master *) Tcl_GetAssocData(askingInterp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("GetTarget: could not find master record"); - } - slaveInterp = GetInterp(askingInterp, masterPtr, path, NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(askingInterp, "could not find interpreter \"", - path, "\"", (char *) NULL); - return TCL_ERROR; - } - slaveSlavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", - NULL); - if (slaveSlavePtr == (Slave *) NULL) { - panic("GetTarget: could not find slave record"); - } - hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendResult(askingInterp, "alias \"", aliasName, "\" in path \"", - path, "\" not found", (char *) NULL); - return TCL_ERROR; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - if (aliasPtr == (Alias *) NULL) { - panic("GetTarget: could not find alias record"); - } - if (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) { - Tcl_ResetResult(askingInterp); - Tcl_AppendResult(askingInterp, "target interpreter for alias \"", - aliasName, "\" in path \"", path, "\" is not my descendant", - (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InterpCmd -- - * - * This procedure is invoked to process the "interp" 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_InterpCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* A master. */ - Master *masterPtr; /* Master record for current interp. */ - Slave *slavePtr; /* Record for slave interp. */ - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - size_t len; /* Length of command name. */ - int result; /* Result of eval. */ - char *cmdName; /* Name of sub command to do. */ - char *cmd; /* Command to eval. */ - Tcl_Channel chan; /* Channel to share or transfer. */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " cmd ?arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - cmdName = argv[1]; - - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_InterpCmd: could not find master record"); - } - - len = strlen(cmdName); - - if (cmdName[0] == 'a') { - if ((strncmp(cmdName, "alias", len) == 0) && (len <= 5)) { - return SlaveAliasHelper(interp, argc, argv); - } - - if (strcmp(cmdName, "aliases") == 0) { - if (argc != 2 && argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " aliases ?path?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "interpreter \"", - argv[2], "\" not found", (char *) NULL); - return TCL_ERROR; - } - } else { - slaveInterp = interp; - } - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, - "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - return TCL_OK; - } - for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - Tcl_AppendElement(interp, - Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr)); - } - return TCL_OK; - } - } - - if ((cmdName[0] == 'c') && (strncmp(cmdName, "create", len) == 0)) { - return CreateInterpObject(interp, argc, argv); - } - - if ((cmdName[0] == 'd') && (strncmp(cmdName, "delete", len) == 0)) { - return DeleteInterpObject(interp, argc, argv); - } - - if (cmdName[0] == 'e') { - if ((strncmp(cmdName, "exists", len) == 0) && (len > 1)) { - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " exists ?path?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - if (GetInterp(interp, masterPtr, argv[2], NULL) == - (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "0", (char *) NULL); - } else { - Tcl_AppendResult(interp, "1", (char *) NULL); - } - } else { - Tcl_AppendResult(interp, "1", (char *) NULL); - } - return TCL_OK; - } - if ((strncmp(cmdName, "eval", len) == 0) && (len > 1)) { - if (argc < 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " eval path arg ?arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "interpreter named \"", argv[2], - "\" not found", (char *) NULL); - return TCL_ERROR; - } - cmd = Tcl_Concat(argc-3, argv+3); - Tcl_Preserve((ClientData) slaveInterp); - result = Tcl_Eval(slaveInterp, cmd); - ckfree((char *) cmd); - - /* - * Now make the result and any error information accessible. We - * have to be careful because the slave interpreter and the current - * interpreter can be the same - do not destroy the result.. This - * can happen if an interpreter contains an alias which is directed - * at a target command in the same interpreter. - */ - - if (interp != slaveInterp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer error information from - * the target 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 slaveInterp's $errorInfo; - * we've already got everything we need in the slave - * interpreter's $errorInfo. - */ - - Tcl_ResetResult(interp); - Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, - "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) - NULL, TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - } - if (slaveInterp->freeProc != NULL) { - interp->result = slaveInterp->result; - interp->freeProc = slaveInterp->freeProc; - slaveInterp->freeProc = 0; - } else { - Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); - } - Tcl_ResetResult(slaveInterp); - } - Tcl_Release((ClientData) slaveInterp); - return result; - } - } - - if ((cmdName[0] == 'i') && (strncmp(cmdName, "issafe", len) == 0)) { - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " issafe ?path?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - slaveInterp = GetInterp(interp, masterPtr, argv[2], &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "interpreter \"", argv[2], - "\" not found", (char *) NULL); - return TCL_ERROR; - } - } - if (masterPtr->isSafe == 0) { - Tcl_AppendResult(interp, "0", (char *) NULL); - } else { - Tcl_AppendResult(interp, "1", (char *) NULL); - } - return TCL_OK; - } - - if (cmdName[0] == 's') { - if ((strncmp(cmdName, "slaves", len) == 0) && (len > 1)) { - if (argc != 2 && argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " slaves ?path?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - if (GetInterp(interp, masterPtr, argv[2], &masterPtr) == - (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "interpreter \"", argv[2], - "\" not found", (char *) NULL); - return TCL_ERROR; - } - } - for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - Tcl_AppendElement(interp, - Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr)); - } - return TCL_OK; - } - if ((strncmp(cmdName, "share", len) == 0) && (len > 1)) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " share srcPath channelId destPath\"", (char *) NULL); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, masterPtr, argv[2], NULL); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "interpreter \"", argv[2], - "\" not found", (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, argv[4], NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "interpreter \"", argv[4], - "\" not found", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(masterInterp, argv[3], NULL); - if (chan == (Tcl_Channel) NULL) { - if (interp != masterInterp) { - Tcl_AppendResult(interp, masterInterp->result, - (char *) NULL); - Tcl_ResetResult(masterInterp); - } - return TCL_ERROR; - } - Tcl_RegisterChannel(slaveInterp, chan); - return TCL_OK; - } - } - - if ((cmdName[0] == 't') && (strncmp(cmdName, "target", len) == 0)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " target path alias\"", (char *) NULL); - return TCL_ERROR; - } - return GetTarget(interp, argv[2], argv[3]); - } - - if ((cmdName[0] == 't') && (strncmp(cmdName, "transfer", len) == 0)) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " transfer srcPath channelId destPath\"", (char *) NULL); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, masterPtr, argv[2], NULL); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "interpreter \"", argv[2], - "\" not found", (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, argv[4], NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "interpreter \"", argv[4], - "\" not found", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(masterInterp, argv[3], NULL); - if (chan == (Tcl_Channel) NULL) { - if (interp != masterInterp) { - Tcl_AppendResult(interp, masterInterp->result, (char *) NULL); - Tcl_ResetResult(masterInterp); - } - return TCL_ERROR; - } - Tcl_RegisterChannel(slaveInterp, chan); - if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - if (interp != masterInterp) { - Tcl_AppendResult(interp, masterInterp->result, (char *) NULL); - Tcl_ResetResult(masterInterp); - } - return TCL_ERROR; - } - - return TCL_OK; - } - - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be alias, aliases, create, delete, exists, eval, ", - "issafe, share, slaves, target or transfer", (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * SlaveObjectCmd -- - * - * Command to manipulate an interpreter, e.g. to send commands to it - * to be evaluated. One such command exists for each slave interpreter. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See user documentation for details. - * - *---------------------------------------------------------------------- - */ - -static int -SlaveObjectCmd( - ClientData clientData, /* Slave interpreter. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Master *masterPtr; /* Master record for slave interp. */ - Slave *slavePtr; /* Slave record. */ - Tcl_Interp *slaveInterp; /* Slave interpreter. */ - char *cmdName; /* Name of command to do. */ - char *cmd; /* Command to evaluate in slave - * interpreter. */ - Alias *aliasPtr; /* Alias information. */ - Tcl_HashEntry *hPtr; /* For local searches. */ - Tcl_HashSearch hSearch; /* For local searches. */ - int result; /* Loop counter, status return. */ - size_t len; /* Length of command name. */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " cmd ?arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - - slaveInterp = (Tcl_Interp *) clientData; - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "interpreter ", argv[0], " has been deleted", - (char *) NULL); - return TCL_ERROR; - } - - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, - "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - panic("SlaveObjectCmd: could not find slave record"); - } - - cmdName = argv[1]; - len = strlen(cmdName); - - if (cmdName[0] == 'a') { - if (strncmp(cmdName, "alias", len) == 0) { - switch (argc-2) { - case 0: - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " alias aliasName ?targetName? ?args..?", - (char *) NULL); - return TCL_ERROR; - - case 1: - - /* - * Return the name of the command in the current - * interpreter for which the argument is an alias in the - * slave interpreter, and the list of saved arguments - */ - - return DescribeAlias(interp, slaveInterp, argv[2]); - - default: - masterPtr = (Master *) Tcl_GetAssocData(interp, - "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("SlaveObjectCmd: could not find master record"); - } - return AliasHelper(interp, slaveInterp, interp, masterPtr, - argv[2], argv[3], argc-4, argv+4); - } - } - - if (strncmp(cmdName, "aliases", len) == 0) { - - /* - * Return the names of all the aliases created in the - * slave interpreter. - */ - - for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), - &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - Tcl_AppendElement(interp, aliasPtr->aliasName); - } - return TCL_OK; - } - } - - - if ((cmdName[0] == 'e') && (strncmp(cmdName, "eval", len) == 0)) { - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " eval arg ?arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - - cmd = Tcl_Concat(argc-2, argv+2); - Tcl_Preserve((ClientData) slaveInterp); - result = Tcl_Eval(slaveInterp, cmd); - ckfree((char *) cmd); - - /* - * Now make the result and any error information accessible. We have - * to be careful because the slave interpreter and the current - * interpreter can be the same - do not destroy the result.. This - * can happen if an interpreter contains an alias which is directed - * at a target command in the same interpreter. - */ - - if (interp != slaveInterp) { - if (result == TCL_ERROR) { - - /* - * 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 slaveInterp's $errorInfo; - * we've already got everything we need in the slave - * interpreter's $errorInfo. - */ - - Tcl_ResetResult(interp); - Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, - "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL, - TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); - } - if (slaveInterp->freeProc != NULL) { - interp->result = slaveInterp->result; - interp->freeProc = slaveInterp->freeProc; - slaveInterp->freeProc = 0; - } else { - Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); - } - Tcl_ResetResult(slaveInterp); - } - Tcl_Release((ClientData) slaveInterp); - return result; - } - - if ((cmdName[0] == 'i') && (strncmp(cmdName, "issafe", len) == 0)) { - if (argc > 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " issafe\"", (char *) NULL); - return TCL_ERROR; - } - masterPtr = (Master *) Tcl_GetAssocData(slaveInterp, - "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("SlaveObjectCmd: could not find master record"); - } - if (masterPtr->isSafe == 1) { - Tcl_AppendResult(interp, "1", (char *) NULL); - } else { - Tcl_AppendResult(interp, "0", (char *) NULL); - } - return TCL_OK; - } - - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be alias, aliases, eval or issafe", (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * SlaveObjectDeleteProc -- - * - * Invoked when an object command for a slave interpreter is deleted; - * cleans up all state associated with the slave interpreter and destroys - * the slave interpreter. - * - * Results: - * None. - * - * Side effects: - * Cleans up all state associated with the slave interpreter and - * destroys the slave interpreter. - * - *---------------------------------------------------------------------- - */ - -static void -SlaveObjectDeleteProc( - ClientData clientData /* The SlaveRecord for the command. */ -) -{ - Slave *slavePtr; /* Interim storage for Slave record. */ - Tcl_Interp *slaveInterp; /* And for a slave interp. */ - - slaveInterp = (Tcl_Interp *) clientData; - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",NULL); - if (slavePtr == (Slave *) NULL) { - panic("SlaveObjectDeleteProc: could not find slave record"); - } - - /* - * Delete the entry in the slave table in the master interpreter now. - * This is to avoid an infinite loop in the Master hash table cleanup in - * the master interpreter. This can happen if this slave is being deleted - * because the master is being deleted and the slave deletion is deferred - * because it is still active. - */ - - Tcl_DeleteHashEntry(slavePtr->slaveEntry); - - /* - * Set to NULL so that when the slave record is cleaned up in the slave - * it does not try to delete the command causing all sorts of grief. - * See SlaveRecordDeleteProc(). - */ - - slavePtr->interpCmd = NULL; - - /* - * Destroy the interpreter - this will cause all the deleteProcs for - * all commands (including aliases) to run. - * - * NOTE: WE ASSUME THAT THE INTERPRETER HAS NOT BEEN DELETED YET!! - */ - - Tcl_DeleteInterp(slavePtr->slaveInterp); -} - -/* - *---------------------------------------------------------------------- - * - * AliasCmd -- - * - * This is the procedure that services invocations of aliases in a - * slave interpreter. One such command exists for each alias. When - * invoked, this procedure redirects the invocation to the target - * command in the master interpreter as designated by the Alias - * record associated with this command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Causes forwarding of the invocation; all possible side effects - * may occur as a result of invoking the command to which the - * invocation is forwarded. - * - *---------------------------------------------------------------------- - */ - -static int -AliasCmd( - ClientData clientData, /* Alias record. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Alias *aliasPtr; /* Describes the alias. */ - Tcl_CmdInfo cmdInfo; /* Info about target command. */ - int result; /* Result of execution. */ - int i, j, addArgc; /* Loop counters. */ - int localArgc; /* Local argument count. */ - char **localArgv; /* Local argument vector. */ - Interp *iPtr; /* The target interpreter. */ - - aliasPtr = (Alias *) clientData; - - result = Tcl_GetCommandInfo(aliasPtr->targetInterp, aliasPtr->targetName, - &cmdInfo); - if (result == 0) { - Tcl_AppendResult(interp, "aliased target \"", aliasPtr->targetName, - "\" for \"", argv[0], "\" not found", (char *) NULL); - return TCL_ERROR; - } - if (aliasPtr->argc <= 0) { - localArgv = argv; - localArgc = argc; - } else { - addArgc = aliasPtr->argc; - localArgc = argc + addArgc; - localArgv = (char **) ckalloc((unsigned) sizeof(char *) * localArgc); - localArgv[0] = argv[0]; - for (i = 0, j = 1; i < addArgc; i++, j++) { - localArgv[j] = aliasPtr->argv[i]; - } - for (i = 1; i < argc; i++, j++) { - localArgv[j] = argv[i]; - } - } - - /* - * Invoke the redirected command in the target interpreter. Note - * that we are not calling eval because of possible security holes with - * $ substitution and bracketed command evaluation. - * - * We duplicate some code here from Tcl_Eval to implement recursion - * level counting and correct deletion of the target interpreter if - * that was requested but delayed because of in-progress evaluations. - */ - - iPtr = (Interp *) aliasPtr->targetInterp; - iPtr->numLevels++; - Tcl_Preserve((ClientData) iPtr); - Tcl_ResetResult((Tcl_Interp *) iPtr); - result = (cmdInfo.proc)(cmdInfo.clientData, (Tcl_Interp *) iPtr, - localArgc, localArgv); - iPtr->numLevels--; - if (iPtr->numLevels == 0) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } - if ((result != TCL_OK) && (result != TCL_ERROR)) { - Tcl_ResetResult((Tcl_Interp *) iPtr); - if (result == TCL_BREAK) { - iPtr->result = "invoked \"break\" outside of a loop"; - } else if (result == TCL_CONTINUE) { - iPtr->result = "invoked \"continue\" outside of a loop"; - } else { - iPtr->result = iPtr->resultSpace; - sprintf(iPtr->resultSpace, "command returned bad code: %d", - result); - } - result = TCL_ERROR; - } - } - - /* - * Clean up any locally allocated argument vector structure. - */ - - if (localArgv != argv) { - ckfree((char *) localArgv); - } - - /* - * - * NOTE: Need to be careful if the target interpreter and the current - * interpreter are the same - must not destroy result. This may happen - * if an alias is created which redirects to a command in the same - * interpreter as the one in which the source command will be defined. - * Also: We cannot use aliasPtr any more because the alias may have - * been deleted. - */ - - if (interp != (Tcl_Interp *) iPtr) { - if (result == TCL_ERROR) { - /* - * An error occurred, so transfer error information from the - * destination interpreter back to our interpreter. Some tricky - * points: - * 1. Must call Tcl_AddErrorInfo in destination interpreter to - * make sure that the errorInfo variable has been initialized - * (it's initialized lazily and might not have been initialized - * yet). - * 2. Must clear interp's result before calling Tcl_AddErrorInfo, - * since Tcl_AddErrorInfo will store the interp's result in - * errorInfo before appending aliasPtr->interp's $errorInfo; - * we've already got everything we need in the redirected - * interpreter's $errorInfo. - */ - - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo((Tcl_Interp *) iPtr, ""); - } - iPtr->flags &= ~ERR_ALREADY_LOGGED; - Tcl_ResetResult(interp); - Tcl_AddErrorInfo(interp, Tcl_GetVar2((Tcl_Interp *) iPtr, - "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2((Tcl_Interp *) iPtr, "errorCode", - (char *) NULL, TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); - } - if (iPtr->freeProc != NULL) { - interp->result = iPtr->result; - interp->freeProc = iPtr->freeProc; - iPtr->freeProc = 0; - } else { - Tcl_SetResult(interp, iPtr->result, TCL_VOLATILE); - } - Tcl_ResetResult((Tcl_Interp *) iPtr); - } - Tcl_Release((ClientData) iPtr); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * AliasCmdDeleteProc -- - * - * Is invoked when an alias command is deleted in a slave. Cleans up - * all storage associated with this alias. - * - * Results: - * None. - * - * Side effects: - * Deletes the alias record and its entry in the alias table for - * the interpreter. - * - *---------------------------------------------------------------------- - */ - -static void -AliasCmdDeleteProc( - ClientData clientData /* The alias record for this alias. */ -) -{ - Alias *aliasPtr; /* Alias record for alias to delete. */ - Target *targetPtr; /* Record for target of this alias. */ - int i; /* Loop counter. */ - - aliasPtr = (Alias *) clientData; - - targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntry); - ckfree((char *) targetPtr); - Tcl_DeleteHashEntry(aliasPtr->targetEntry); - - ckfree((char *) aliasPtr->targetName); - ckfree((char *) aliasPtr->aliasName); - for (i = 0; i < aliasPtr->argc; i++) { - ckfree((char *) aliasPtr->argv[i]); - } - if (aliasPtr->argv != (char **) NULL) { - ckfree((char *) aliasPtr->argv); - } - - Tcl_DeleteHashEntry(aliasPtr->aliasEntry); - - ckfree((char *) aliasPtr); -} - -/* - *---------------------------------------------------------------------- - * - * MasterRecordDeleteProc - - * - * Is invoked when an interpreter (which is using the "interp" facility) - * is deleted, and it cleans up the storage associated with the - * "tclMasterRecord" assoc-data entry. - * - * Results: - * None. - * - * Side effects: - * Cleans up storage. - * - *---------------------------------------------------------------------- - */ - -static void -MasterRecordDeleteProc( - ClientData clientData, /* Master record for deleted interp. */ - Tcl_Interp *interp /* Interpreter being deleted. */ -) -{ - Target *targetPtr; /* Loop variable. */ - Tcl_HashEntry *hPtr; /* Search element. */ - Tcl_HashSearch hSearch; /* Search record (internal). */ - Slave *slavePtr; /* Loop variable. */ - char *cmdName; /* Name of command to delete. */ - Master *masterPtr; /* Interim storage. */ - - masterPtr = (Master *) clientData; - for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - cmdName = Tcl_GetCommandName(interp, slavePtr->interpCmd); - (void) Tcl_DeleteCommand(interp, cmdName); - } - Tcl_DeleteHashTable(&(masterPtr->slaveTable)); - - for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) { - targetPtr = (Target *) Tcl_GetHashValue(hPtr); - cmdName = Tcl_GetCommandName(targetPtr->slaveInterp, - targetPtr->slaveCmd); - (void) Tcl_DeleteCommand(targetPtr->slaveInterp, cmdName); - } - Tcl_DeleteHashTable(&(masterPtr->targetTable)); - - ckfree((char *) masterPtr); -} - -/* - *---------------------------------------------------------------------- - * - * SlaveRecordDeleteProc -- - * - * Is invoked when an interpreter (which is using the interp facility) - * is deleted, and it cleans up the storage associated with the - * tclSlaveRecord assoc-data entry. - * - * Results: - * None - * - * Side effects: - * Cleans up storage. - * - *---------------------------------------------------------------------- - */ - -static void -SlaveRecordDeleteProc( - ClientData clientData, /* Slave record for deleted interp. */ - Tcl_Interp *interp /* Interpreter being deleted. */ -) -{ - Slave *slavePtr; /* Interim storage. */ - Alias *aliasPtr; - Tcl_HashTable *hTblPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - - slavePtr = (Slave *) clientData; - - /* - * In every case that we call SetAssocData on "tclSlaveRecord", - * slavePtr is not NULL. Otherwise we panic. - */ - - if (slavePtr == NULL) { - panic("SlaveRecordDeleteProc: NULL slavePtr"); - } - - if (slavePtr->interpCmd != (Tcl_Command) NULL) { - Command *cmdPtr = (Command *) slavePtr->interpCmd; - - /* - * The interpCmd has not been deleted in the master yet, since - * it's callback sets interpCmd to NULL. - * - * Probably Tcl_DeleteInterp() was called on this interpreter directly, - * rather than via "interp delete", or equivalent (deletion of the - * command in the master). - * - * Perform the cleanup done by SlaveObjectDeleteProc() directly, - * and turn off the callback now (since we are about to free slavePtr - * and this interpreter is going away, while the deletion of commands - * in the master may be deferred). - */ - - Tcl_DeleteHashEntry(slavePtr->slaveEntry); - cmdPtr->clientData = NULL; - cmdPtr->deleteProc = NULL; - cmdPtr->deleteData = NULL; - - /* - * Get the command name from the master interpreter instead of - * relying on the stored name; the command may have been renamed. - */ - - Tcl_DeleteCommand(slavePtr->masterInterp, - Tcl_GetCommandName(slavePtr->masterInterp, - slavePtr->interpCmd)); - } - - /* - * If there are any aliases, delete those now. This removes any - * dependency on the order of deletion between commands and the - * slave record. - */ - - hTblPtr = (Tcl_HashTable *) &(slavePtr->aliasTable); - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - - /* - * The call to Tcl_DeleteCommand will release the storage - * occuppied by the hash entry and the alias record. - * NOTE that we cannot use the alias name directly because its - * storage will be deleted in the command deletion callback. Hence - * we must use the name for the command as stored in the hash table. - */ - - Tcl_DeleteCommand(interp, - Tcl_GetCommandName(interp, aliasPtr->slaveCmd)); - } - - /* - * Finally dispose of the slave record itself. - */ - - ckfree((char *) slavePtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclInterpInit -- - * - * Initializes the invoking interpreter for using the "interp" - * facility. This is called from inside Tcl_Init. - * - * Results: - * None. - * - * Side effects: - * Adds the "interp" command to an interpreter and initializes several - * records in the associated data of the invoking interpreter. - * - *---------------------------------------------------------------------- - */ - -int -TclInterpInit( - Tcl_Interp *interp /* Interpreter to initialize. */ -) -{ - Master *masterPtr; /* Its Master record. */ - - masterPtr = (Master *) ckalloc((unsigned) sizeof(Master)); - masterPtr->isSafe = 0; - Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS); - Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS); - - (void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc, - (ClientData) masterPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_IsSafe -- - * - * Determines whether an interpreter is safe - * - * Results: - * 1 if it is safe, 0 if it is not. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_IsSafe( - Tcl_Interp *interp /* Is this interpreter "safe" ? */ -) -{ - Master *masterPtr; /* Its master record. */ - - if (interp == (Tcl_Interp *) NULL) { - return 0; - } - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_IsSafe: could not find master record"); - } - return masterPtr->isSafe; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_MakeSafe -- - * - * Makes an interpreter safe. - * - * Results: - * TCL_OK if it succeeds, TCL_ERROR else. - * - * Side effects: - * Removes functionality from an interpreter. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_MakeSafe( - Tcl_Interp *interp /* Make this interpreter "safe". */ -) -{ - if (interp == (Tcl_Interp *) NULL) { - return TCL_ERROR; - } - return MakeSafe(interp); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateSlave -- - * - * Creates a slave interpreter. The slavePath argument denotes the - * name of the new slave relative to the current interpreter; the - * slave is a direct descendant of the one-before-last component of - * the path, e.g. it is a descendant of the current interpreter if - * the slavePath argument contains only one component. Optionally makes - * the slave interpreter safe. - * - * Results: - * Returns the interpreter structure created, or NULL if an error - * occurred. - * - * Side effects: - * Creates a new interpreter and a new interpreter object command in - * the interpreter indicated by the slavePath argument. - * - *---------------------------------------------------------------------- - */ - -Tcl_Interp * -Tcl_CreateSlave( - Tcl_Interp *interp, /* Interpreter to start search at. */ - char *slavePath, /* Name of slave to create. */ - int isSafe /* Should new slave be "safe" ? */ -) -{ - if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { - return NULL; - } - return CreateSlave(interp, slavePath, isSafe); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetSlave -- - * - * Finds a slave interpreter by its path name. - * - * Results: - * Returns a Tcl_Interp * for the named interpreter or NULL if not - * found. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Interp * -Tcl_GetSlave( - Tcl_Interp *interp, /* Interpreter to start search from. */ - char *slavePath /* Path of slave to find. */ -) -{ - Master *masterPtr; /* Interim storage for Master record. */ - - if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { - return NULL; - } - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_GetSlave: could not find master record"); - } - return GetInterp(interp, masterPtr, slavePath, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetMaster -- - * - * Finds the master interpreter of a slave interpreter. - * - * Results: - * Returns a Tcl_Interp * for the master interpreter or NULL if none. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Interp * -Tcl_GetMaster( - Tcl_Interp *interp /* Get the master of this interpreter. */ -) -{ - Slave *slavePtr; /* Slave record of this interpreter. */ - - if (interp == (Tcl_Interp *) NULL) { - return NULL; - } - slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - return NULL; - } - return slavePtr->masterInterp; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateAlias -- - * - * Creates an alias between two interpreters. - * - * Results: - * TCL_OK if successful, TCL_ERROR if failed. If TCL_ERROR is returned - * the result of slaveInterp will contain an error message. - * - * Side effects: - * Creates a new alias, manipulates the result field of slaveInterp. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_CreateAlias( - Tcl_Interp *slaveInterp, /* Interpreter for source command. */ - char *slaveCmd, /* Command to install in slave. */ - Tcl_Interp *targetInterp, /* Interpreter for target command. */ - char *targetCmd, /* Name of target command. */ - int argc, /* How many additional arguments? */ - char **argv /* These are the additional args. */ -) -{ - Master *masterPtr; /* Master record for target interp. */ - - if ((slaveInterp == (Tcl_Interp *) NULL) || - (targetInterp == (Tcl_Interp *) NULL) || - (slaveCmd == (char *) NULL) || - (targetCmd == (char *) NULL)) { - return TCL_ERROR; - } - masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_CreateAlias: could not find master record"); - } - return AliasHelper(slaveInterp, slaveInterp, targetInterp, masterPtr, - slaveCmd, targetCmd, argc, argv); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetAlias -- - * - * Gets information about an alias. - * - * Results: - * TCL_OK if successful, TCL_ERROR else. If TCL_ERROR is returned, the - * result field of the interpreter given as argument will contain an - * error message. - * - * Side effects: - * Manipulates the result field of the interpreter given as argument. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetAlias( - Tcl_Interp *interp, /* Interp to start search from. */ - char *aliasName, /* Name of alias to find. */ - Tcl_Interp **targetInterpPtr, /* (Return) target interpreter. */ - char **targetNamePtr, /* (Return) name of target command. */ - int *argcPtr, /* (Return) count of addnl args. */ - char ***argvPtr /* (Return) additional arguments. */ -) -{ - Slave *slavePtr; /* Slave record for slave interp. */ - Tcl_HashEntry *hPtr; /* Search element. */ - Alias *aliasPtr; /* Storage for alias found. */ - - if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) { - return TCL_ERROR; - } - slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - panic("Tcl_GetAlias: could not find slave record"); - } - hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", - (char *) NULL); - return TCL_ERROR; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - if (targetInterpPtr != (Tcl_Interp **) NULL) { - *targetInterpPtr = aliasPtr->targetInterp; - } - if (targetNamePtr != (char **) NULL) { - *targetNamePtr = aliasPtr->targetName; - } - if (argcPtr != (int *) NULL) { - *argcPtr = aliasPtr->argc; - } - if (argvPtr != (char ***) NULL) { - *argvPtr = aliasPtr->argv; - } - return TCL_OK; -} diff --git a/cde/programs/dtdocbook/tcl/tclLink.c b/cde/programs/dtdocbook/tcl/tclLink.c deleted file mode 100644 index 15f0c33e..00000000 --- a/cde/programs/dtdocbook/tcl/tclLink.c +++ /dev/null @@ -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 "??"; -} diff --git a/cde/programs/dtdocbook/tcl/tclLoad.c b/cde/programs/dtdocbook/tcl/tclLoad.c deleted file mode 100644 index 4a5d063f..00000000 --- a/cde/programs/dtdocbook/tcl/tclLoad.c +++ /dev/null @@ -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); - } -} diff --git a/cde/programs/dtdocbook/tcl/tclLoadNone.c b/cde/programs/dtdocbook/tcl/tclLoadNone.c deleted file mode 100644 index 408afd3f..00000000 --- a/cde/programs/dtdocbook/tcl/tclLoadNone.c +++ /dev/null @@ -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; -} diff --git a/cde/programs/dtdocbook/tcl/tclMain.c b/cde/programs/dtdocbook/tcl/tclMain.c deleted file mode 100644 index e41354fc..00000000 --- a/cde/programs/dtdocbook/tcl/tclMain.c +++ /dev/null @@ -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 diff --git a/cde/programs/dtdocbook/tcl/tclMtherr.c b/cde/programs/dtdocbook/tcl/tclMtherr.c deleted file mode 100644 index b92b84c9..00000000 --- a/cde/programs/dtdocbook/tcl/tclMtherr.c +++ /dev/null @@ -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 - -#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 -/* 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; -} diff --git a/cde/programs/dtdocbook/tcl/tclNotify.c b/cde/programs/dtdocbook/tcl/tclNotify.c deleted file mode 100644 index 5fe36df5..00000000 --- a/cde/programs/dtdocbook/tcl/tclNotify.c +++ /dev/null @@ -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; - } - } -} diff --git a/cde/programs/dtdocbook/tcl/tclParse.c b/cde/programs/dtdocbook/tcl/tclParse.c deleted file mode 100644 index ac0c832f..00000000 --- a/cde/programs/dtdocbook/tcl/tclParse.c +++ /dev/null @@ -1,1420 +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: tclParse.c /main/2 1996/08/08 14:45:49 cde-hp $ */ -/* - * tclParse.c -- - * - * This file contains a collection of procedures that are used - * to parse Tcl commands or parts of commands (like quoted - * strings or nested sub-commands). - * - * Copyright (c) 1987-1993 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: @(#) tclParse.c 1.50 96/03/02 14:46:55 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * The following table assigns a type to each character. Only types - * meaningful to Tcl parsing are represented here. The table is - * designed to be referenced with either signed or unsigned characters, - * so it has 384 entries. The first 128 entries correspond to negative - * character values, the next 256 correspond to positive character - * values. The last 128 entries are identical to the first 128. The - * table is always indexed with a 128-byte offset (the 128th entry - * corresponds to a 0 character value). - */ - -char tclTypeTable[] = { - /* - * Negative character values, from -128 to -1: - */ - - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - - /* - * Positive character values, from 0-127: - */ - - TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE, - TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL, - TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET, - TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE, - TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL, - - /* - * Large unsigned character values, from 128-255: - */ - - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, -}; - -/* - * Function prototypes for procedures local to this file: - */ - -static char * QuoteEnd _ANSI_ARGS_((char *string, int term)); -static char * ScriptEnd _ANSI_ARGS_((char *p, int nested)); -static char * VarNameEnd _ANSI_ARGS_((char *string)); - -/* - *---------------------------------------------------------------------- - * - * Tcl_Backslash -- - * - * Figure out how to handle a backslash sequence. - * - * Results: - * The return value is the character that should be substituted - * in place of the backslash sequence that starts at src. If - * readPtr isn't NULL then it is filled in with a count of the - * number of characters in the backslash sequence. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char -Tcl_Backslash( - char *src, /* Points to the backslash character of - * a backslash sequence. */ - int *readPtr /* Fill in with number of characters read - * from src, unless NULL. */ -) -{ - char *p = src+1; - char result; - int count; - - count = 2; - - switch (*p) { - case 'a': - result = 0x7; /* Don't say '\a' here, since some compilers */ - break; /* don't support it. */ - case 'b': - result = '\b'; - break; - case 'f': - result = '\f'; - break; - case 'n': - result = '\n'; - break; - case 'r': - result = '\r'; - break; - case 't': - result = '\t'; - break; - case 'v': - result = '\v'; - break; - case 'x': - if (isxdigit(UCHAR(p[1]))) { - char *end; - - result = (char) strtoul(p+1, &end, 16); - count = end - src; - } else { - count = 2; - result = 'x'; - } - break; - case '\n': - do { - p++; - } while ((*p == ' ') || (*p == '\t')); - result = ' '; - count = p - src; - break; - case 0: - result = '\\'; - count = 1; - break; - default: - if (isdigit(UCHAR(*p))) { - result = (char)(*p - '0'); - p++; - if (!isdigit(UCHAR(*p))) { - break; - } - count = 3; - result = (char)((result << 3) + (*p - '0')); - p++; - if (!isdigit(UCHAR(*p))) { - break; - } - count = 4; - result = (char)((result << 3) + (*p - '0')); - break; - } - result = *p; - count = 2; - break; - } - - if (readPtr != NULL) { - *readPtr = count; - } - return result; -} - -/* - *-------------------------------------------------------------- - * - * TclParseQuotes -- - * - * This procedure parses a double-quoted string such as a - * quoted Tcl command argument or a quoted value in a Tcl - * expression. This procedure is also used to parse array - * element names within parentheses, or anything else that - * needs all the substitutions that happen in quotes. - * - * Results: - * The return value is a standard Tcl result, which is - * TCL_OK unless there was an error while parsing the - * quoted string. If an error occurs then interp->result - * contains a standard error message. *TermPtr is filled - * in with the address of the character just after the - * last one successfully processed; this is usually the - * character just after the matching close-quote. The - * fully-substituted contents of the quotes are stored in - * standard fashion in *pvPtr, null-terminated with - * pvPtr->next pointing to the terminating null character. - * - * Side effects: - * The buffer space in pvPtr may be enlarged by calling its - * expandProc. - * - *-------------------------------------------------------------- - */ - -int -TclParseQuotes( - Tcl_Interp *interp, /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string, /* Character just after opening double- - * quote. */ - int termChar, /* Character that terminates "quoted" string - * (usually double-quote, but sometimes - * right-paren or something else). */ - int flags, /* Flags to pass to nested Tcl_Eval calls. */ - char **termPtr, /* Store address of terminating character - * here. */ - ParseValue *pvPtr /* Information about where to place - * fully-substituted result of parse. */ -) -{ - char *src, *dst, c; - - src = string; - dst = pvPtr->next; - - while (1) { - if (dst == pvPtr->end) { - /* - * Target buffer space is about to run out. Make more space. - */ - - pvPtr->next = dst; - (*pvPtr->expandProc)(pvPtr, 1); - dst = pvPtr->next; - } - - c = *src; - src++; - if (c == termChar) { - *dst = '\0'; - pvPtr->next = dst; - *termPtr = src; - return TCL_OK; - } else if (CHAR_TYPE(c) == TCL_NORMAL) { - copy: - *dst = c; - dst++; - continue; - } else if (c == '$') { - int length; - char *value; - - value = Tcl_ParseVar(interp, src-1, termPtr); - if (value == NULL) { - return TCL_ERROR; - } - src = *termPtr; - length = strlen(value); - if ((pvPtr->end - dst) <= length) { - pvPtr->next = dst; - (*pvPtr->expandProc)(pvPtr, length); - dst = pvPtr->next; - } - strcpy(dst, value); - dst += length; - continue; - } else if (c == '[') { - int result; - - pvPtr->next = dst; - result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr); - if (result != TCL_OK) { - return result; - } - src = *termPtr; - dst = pvPtr->next; - continue; - } else if (c == '\\') { - int numRead; - - src--; - *dst = Tcl_Backslash(src, &numRead); - dst++; - src += numRead; - continue; - } else if (c == '\0') { - Tcl_ResetResult(interp); - sprintf(interp->result, "missing %c", termChar); - *termPtr = string-1; - return TCL_ERROR; - } else { - goto copy; - } - } -} - -/* - *-------------------------------------------------------------- - * - * TclParseNestedCmd -- - * - * This procedure parses a nested Tcl command between - * brackets, returning the result of the command. - * - * Results: - * The return value is a standard Tcl result, which is - * TCL_OK unless there was an error while executing the - * nested command. If an error occurs then interp->result - * contains a standard error message. *TermPtr is filled - * in with the address of the character just after the - * last one processed; this is usually the character just - * after the matching close-bracket, or the null character - * at the end of the string if the close-bracket was missing - * (a missing close bracket is an error). The result returned - * by the command is stored in standard fashion in *pvPtr, - * null-terminated, with pvPtr->next pointing to the null - * character. - * - * Side effects: - * The storage space at *pvPtr may be expanded. - * - *-------------------------------------------------------------- - */ - -int -TclParseNestedCmd( - Tcl_Interp *interp, /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string, /* Character just after opening bracket. */ - int flags, /* Flags to pass to nested Tcl_Eval. */ - char **termPtr, /* Store address of terminating character - * here. */ - ParseValue *pvPtr /* Information about where to place - * result of command. */ -) -{ - int result, length, shortfall; - Interp *iPtr = (Interp *) interp; - - iPtr->evalFlags = flags | TCL_BRACKET_TERM; - result = Tcl_Eval(interp, string); - *termPtr = iPtr->termPtr; - if (result != TCL_OK) { - /* - * The increment below results in slightly cleaner message in - * the errorInfo variable (the close-bracket will appear). - */ - - if (**termPtr == ']') { - *termPtr += 1; - } - return result; - } - (*termPtr) += 1; - length = strlen(iPtr->result); - shortfall = length + 1 - (pvPtr->end - pvPtr->next); - if (shortfall > 0) { - (*pvPtr->expandProc)(pvPtr, shortfall); - } - strcpy(pvPtr->next, iPtr->result); - pvPtr->next += length; - Tcl_FreeResult(iPtr); - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = '\0'; - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * TclParseBraces -- - * - * This procedure scans the information between matching - * curly braces. - * - * Results: - * The return value is a standard Tcl result, which is - * TCL_OK unless there was an error while parsing string. - * If an error occurs then interp->result contains a - * standard error message. *TermPtr is filled - * in with the address of the character just after the - * last one successfully processed; this is usually the - * character just after the matching close-brace. The - * information between curly braces is stored in standard - * fashion in *pvPtr, null-terminated with pvPtr->next - * pointing to the terminating null character. - * - * Side effects: - * The storage space at *pvPtr may be expanded. - * - *-------------------------------------------------------------- - */ - -int -TclParseBraces( - Tcl_Interp *interp, /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string, /* Character just after opening bracket. */ - char **termPtr, /* Store address of terminating character - * here. */ - ParseValue *pvPtr /* Information about where to place - * result of command. */ -) -{ - int level; - char *src, *dst, *end; - char c; - - src = string; - dst = pvPtr->next; - end = pvPtr->end; - level = 1; - - /* - * Copy the characters one at a time to the result area, stopping - * when the matching close-brace is found. - */ - - while (1) { - c = *src; - src++; - if (dst == end) { - pvPtr->next = dst; - (*pvPtr->expandProc)(pvPtr, 20); - dst = pvPtr->next; - end = pvPtr->end; - } - *dst = c; - dst++; - if (CHAR_TYPE(c) == TCL_NORMAL) { - continue; - } else if (c == '{') { - level++; - } else if (c == '}') { - level--; - if (level == 0) { - dst--; /* Don't copy the last close brace. */ - break; - } - } else if (c == '\\') { - int count; - - /* - * Must always squish out backslash-newlines, even when in - * braces. This is needed so that this sequence can appear - * anywhere in a command, such as the middle of an expression. - */ - - if (*src == '\n') { - dst[-1] = Tcl_Backslash(src-1, &count); - src += count - 1; - } else { - (void) Tcl_Backslash(src-1, &count); - while (count > 1) { - if (dst == end) { - pvPtr->next = dst; - (*pvPtr->expandProc)(pvPtr, 20); - dst = pvPtr->next; - end = pvPtr->end; - } - *dst = *src; - dst++; - src++; - count--; - } - } - } else if (c == '\0') { - Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); - *termPtr = string-1; - return TCL_ERROR; - } - } - - *dst = '\0'; - pvPtr->next = dst; - *termPtr = src; - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * TclParseWords -- - * - * This procedure parses one or more words from a command - * string and creates argv-style pointers to fully-substituted - * copies of those words. - * - * Results: - * The return value is a standard Tcl result. - * - * *argcPtr is modified to hold a count of the number of words - * successfully parsed, which may be 0. At most maxWords words - * will be parsed. If 0 <= *argcPtr < maxWords then it - * means that a command separator was seen. If *argcPtr - * is maxWords then it means that a command separator was - * not seen yet. - * - * *TermPtr is filled in with the address of the character - * just after the last one successfully processed in the - * last word. This is either the command terminator (if - * *argcPtr < maxWords), the character just after the last - * one in a word (if *argcPtr is maxWords), or the vicinity - * of an error (if the result is not TCL_OK). - * - * The pointers at *argv are filled in with pointers to the - * fully-substituted words, and the actual contents of the - * words are copied to the buffer at pvPtr. - * - * If an error occurrs then an error message is left in - * interp->result and the information at *argv, *argcPtr, - * and *pvPtr may be incomplete. - * - * Side effects: - * The buffer space in pvPtr may be enlarged by calling its - * expandProc. - * - *-------------------------------------------------------------- - */ - -int -TclParseWords( - Tcl_Interp *interp, /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string, /* First character of word. */ - int flags, /* Flags to control parsing (same values as - * passed to Tcl_Eval). */ - int maxWords, /* Maximum number of words to parse. */ - char **termPtr, /* Store address of terminating character - * here. */ - int *argcPtr, /* Filled in with actual number of words - * parsed. */ - char **argv, /* Store addresses of individual words here. */ - ParseValue *pvPtr /* Information about where to place - * fully-substituted word. */ -) -{ - char *src, *dst; - char c; - int type, result, argc; - char *oldBuffer; /* Used to detect when pvPtr's buffer gets - * reallocated, so we can adjust all of the - * argv pointers. */ - - src = string; - oldBuffer = pvPtr->buffer; - dst = pvPtr->next; - for (argc = 0; argc < maxWords; argc++) { - argv[argc] = dst; - - /* - * Skip leading space. - */ - - skipSpace: - c = *src; - type = CHAR_TYPE(c); - while (type == TCL_SPACE) { - src++; - c = *src; - type = CHAR_TYPE(c); - } - - /* - * Handle the normal case (i.e. no leading double-quote or brace). - */ - - if (type == TCL_NORMAL) { - normalArg: - while (1) { - if (dst == pvPtr->end) { - /* - * Target buffer space is about to run out. Make - * more space. - */ - - pvPtr->next = dst; - (*pvPtr->expandProc)(pvPtr, 1); - dst = pvPtr->next; - } - - if (type == TCL_NORMAL) { - copy: - *dst = c; - dst++; - src++; - } else if (type == TCL_SPACE) { - goto wordEnd; - } else if (type == TCL_DOLLAR) { - int length; - char *value; - - value = Tcl_ParseVar(interp, src, termPtr); - if (value == NULL) { - return TCL_ERROR; - } - src = *termPtr; - length = strlen(value); - if ((pvPtr->end - dst) <= length) { - pvPtr->next = dst; - (*pvPtr->expandProc)(pvPtr, length); - dst = pvPtr->next; - } - strcpy(dst, value); - dst += length; - } else if (type == TCL_COMMAND_END) { - if ((c == ']') && !(flags & TCL_BRACKET_TERM)) { - goto copy; - } - - /* - * End of command; simulate a word-end first, so - * that the end-of-command can be processed as the - * first thing in a new word. - */ - - goto wordEnd; - } else if (type == TCL_OPEN_BRACKET) { - pvPtr->next = dst; - result = TclParseNestedCmd(interp, src+1, flags, termPtr, - pvPtr); - if (result != TCL_OK) { - return result; - } - src = *termPtr; - dst = pvPtr->next; - } else if (type == TCL_BACKSLASH) { - int numRead; - - *dst = Tcl_Backslash(src, &numRead); - - /* - * The following special check allows a backslash-newline - * to be treated as a word-separator, as if the backslash - * and newline had been collapsed before command parsing - * began. - */ - - if (src[1] == '\n') { - src += numRead; - goto wordEnd; - } - src += numRead; - dst++; - } else { - goto copy; - } - c = *src; - type = CHAR_TYPE(c); - } - } else { - - /* - * Check for the end of the command. - */ - - if (type == TCL_COMMAND_END) { - if (flags & TCL_BRACKET_TERM) { - if (c == '\0') { - Tcl_SetResult(interp, "missing close-bracket", - TCL_STATIC); - return TCL_ERROR; - } - } else { - if (c == ']') { - goto normalArg; - } - } - goto done; - } - - /* - * Now handle the special cases: open braces, double-quotes, - * and backslash-newline. - */ - - pvPtr->next = dst; - if (type == TCL_QUOTE) { - result = TclParseQuotes(interp, src+1, '"', flags, - termPtr, pvPtr); - } else if (type == TCL_OPEN_BRACE) { - result = TclParseBraces(interp, src+1, termPtr, pvPtr); - } else if ((type == TCL_BACKSLASH) && (src[1] == '\n')) { - /* - * This code is needed so that a backslash-newline at the - * very beginning of a word is treated as part of the white - * space between words and not as a space within the word. - */ - - src += 2; - goto skipSpace; - } else { - goto normalArg; - } - if (result != TCL_OK) { - return result; - } - - /* - * Back from quotes or braces; make sure that the terminating - * character was the end of the word. - */ - - c = **termPtr; - if ((c == '\\') && ((*termPtr)[1] == '\n')) { - /* - * Line is continued on next line; the backslash-newline - * sequence turns into space, which is OK. No need to do - * anything here. - */ - } else { - type = CHAR_TYPE(c); - if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) { - if (*src == '"') { - Tcl_SetResult(interp, - "extra characters after close-quote", - TCL_STATIC); - } else { - Tcl_SetResult(interp, - "extra characters after close-brace", - TCL_STATIC); - } - return TCL_ERROR; - } - } - src = *termPtr; - dst = pvPtr->next; - } - - /* - * We're at the end of a word, so add a null terminator. Then - * see if the buffer was re-allocated during this word. If so, - * update all of the argv pointers. - */ - - wordEnd: - *dst = '\0'; - dst++; - if (oldBuffer != pvPtr->buffer) { - int i; - - for (i = 0; i <= argc; i++) { - argv[i] = pvPtr->buffer + (argv[i] - oldBuffer); - } - oldBuffer = pvPtr->buffer; - } - } - - done: - pvPtr->next = dst; - *termPtr = src; - *argcPtr = argc; - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * TclExpandParseValue -- - * - * This procedure is commonly used as the value of the - * expandProc in a ParseValue. It uses malloc to allocate - * more space for the result of a parse. - * - * Results: - * The buffer space in *pvPtr is reallocated to something - * larger, and if pvPtr->clientData is non-zero the old - * buffer is freed. Information is copied from the old - * buffer to the new one. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -void -TclExpandParseValue( - ParseValue *pvPtr, /* Information about buffer that - * must be expanded. If the clientData - * in the structure is non-zero, it - * means that the current buffer is - * dynamically allocated. */ - int needed /* Minimum amount of additional space - * to allocate. */ -) -{ - int newSpace; - char *new; - - /* - * Either double the size of the buffer or add enough new space - * to meet the demand, whichever produces a larger new buffer. - */ - - newSpace = (pvPtr->end - pvPtr->buffer) + 1; - if (newSpace < needed) { - newSpace += needed; - } else { - newSpace += newSpace; - } - new = (char *) ckalloc((unsigned) newSpace); - - /* - * Copy from old buffer to new, free old buffer if needed, and - * mark new buffer as malloc-ed. - */ - - memcpy((VOID *) new, (VOID *) pvPtr->buffer, - (size_t) (pvPtr->next - pvPtr->buffer)); - pvPtr->next = new + (pvPtr->next - pvPtr->buffer); - if (pvPtr->clientData != 0) { - ckfree(pvPtr->buffer); - } - pvPtr->buffer = new; - pvPtr->end = new + newSpace - 1; - pvPtr->clientData = (ClientData) 1; -} - -/* - *---------------------------------------------------------------------- - * - * TclWordEnd -- - * - * Given a pointer into a Tcl command, find the end of the next - * word of the command. - * - * Results: - * The return value is a pointer to the last character that's part - * of the word pointed to by "start". If the word doesn't end - * properly within the string then the return value is the address - * of the null character at the end of the string. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclWordEnd( - char *start, /* Beginning of a word of a Tcl command. */ - int nested, /* Zero means this is a top-level command. - * One means this is a nested command (close - * bracket is a word terminator). */ - int *semiPtr /* Set to 1 if word ends with a command- - * terminating semi-colon, zero otherwise. - * If NULL then ignored. */ -) -{ - char *p; - int count; - - if (semiPtr != NULL) { - *semiPtr = 0; - } - - /* - * Skip leading white space (backslash-newline must be treated like - * white-space, except that it better not be the last thing in the - * command). - */ - - for (p = start; ; p++) { - if (isspace(UCHAR(*p))) { - continue; - } - if ((p[0] == '\\') && (p[1] == '\n')) { - if (p[2] == 0) { - return p+2; - } - continue; - } - break; - } - - /* - * Handle words beginning with a double-quote or a brace. - */ - - if (*p == '"') { - p = QuoteEnd(p+1, '"'); - if (*p == 0) { - return p; - } - p++; - } else if (*p == '{') { - int braces = 1; - while (braces != 0) { - p++; - while (*p == '\\') { - (void) Tcl_Backslash(p, &count); - p += count; - } - if (*p == '}') { - braces--; - } else if (*p == '{') { - braces++; - } else if (*p == 0) { - return p; - } - } - p++; - } - - /* - * Handle words that don't start with a brace or double-quote. - * This code is also invoked if the word starts with a brace or - * double-quote and there is garbage after the closing brace or - * quote. This is an error as far as Tcl_Eval is concerned, but - * for here the garbage is treated as part of the word. - */ - - while (1) { - if (*p == '[') { - p = ScriptEnd(p+1, 1); - if (*p == 0) { - return p; - } - p++; - } else if (*p == '\\') { - if (p[1] == '\n') { - /* - * Backslash-newline: it maps to a space character - * that is a word separator, so the word ends just before - * the backslash. - */ - - return p-1; - } - (void) Tcl_Backslash(p, &count); - p += count; - } else if (*p == '$') { - p = VarNameEnd(p); - if (*p == 0) { - return p; - } - p++; - } else if (*p == ';') { - /* - * Include the semi-colon in the word that is returned. - */ - - if (semiPtr != NULL) { - *semiPtr = 1; - } - return p; - } else if (isspace(UCHAR(*p))) { - return p-1; - } else if ((*p == ']') && nested) { - return p-1; - } else if (*p == 0) { - if (nested) { - /* - * Nested commands can't end because of the end of the - * string. - */ - return p; - } - return p-1; - } else { - p++; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * QuoteEnd -- - * - * Given a pointer to a string that obeys the parsing conventions - * for quoted things in Tcl, find the end of that quoted thing. - * The actual thing may be a quoted argument or a parenthesized - * index name. - * - * Results: - * The return value is a pointer to the last character that is - * part of the quoted string (i.e the character that's equal to - * term). If the quoted string doesn't terminate properly then - * the return value is a pointer to the null character at the - * end of the string. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -QuoteEnd( - char *string, /* Pointer to character just after opening - * "quote". */ - int term /* This character will terminate the - * quoted string (e.g. '"' or ')'). */ -) -{ - char *p = string; - int count; - - while (*p != term) { - if (*p == '\\') { - (void) Tcl_Backslash(p, &count); - p += count; - } else if (*p == '[') { - for (p++; *p != ']'; p++) { - p = TclWordEnd(p, 1, (int *) NULL); - if (*p == 0) { - return p; - } - } - p++; - } else if (*p == '$') { - p = VarNameEnd(p); - if (*p == 0) { - return p; - } - p++; - } else if (*p == 0) { - return p; - } else { - p++; - } - } - return p-1; -} - -/* - *---------------------------------------------------------------------- - * - * VarNameEnd -- - * - * Given a pointer to a variable reference using $-notation, find - * the end of the variable name spec. - * - * Results: - * The return value is a pointer to the last character that - * is part of the variable name. If the variable name doesn't - * terminate properly then the return value is a pointer to the - * null character at the end of the string. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -VarNameEnd( - char *string /* Pointer to dollar-sign character. */ -) -{ - char *p = string+1; - - if (*p == '{') { - for (p++; (*p != '}') && (*p != 0); p++) { - /* Empty loop body. */ - } - return p; - } - while (isalnum(UCHAR(*p)) || (*p == '_')) { - p++; - } - if ((*p == '(') && (p != string+1)) { - return QuoteEnd(p+1, ')'); - } - return p-1; -} - - -/* - *---------------------------------------------------------------------- - * - * ScriptEnd -- - * - * Given a pointer to the beginning of a Tcl script, find the end of - * the script. - * - * Results: - * The return value is a pointer to the last character that's part - * of the script pointed to by "p". If the command doesn't end - * properly within the string then the return value is the address - * of the null character at the end of the string. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -ScriptEnd( - char *p, /* Script to check. */ - int nested /* Zero means this is a top-level command. - * One means this is a nested command (the - * last character of the script must be - * an unquoted ]). */ -) -{ - int commentOK = 1; - int length; - - while (1) { - while (isspace(UCHAR(*p))) { - if (*p == '\n') { - commentOK = 1; - } - p++; - } - if ((*p == '#') && commentOK) { - do { - if (*p == '\\') { - /* - * If the script ends with backslash-newline, then - * this command isn't complete. - */ - - if ((p[1] == '\n') && (p[2] == 0)) { - return p+2; - } - Tcl_Backslash(p, &length); - p += length; - } else { - p++; - } - } while ((*p != 0) && (*p != '\n')); - continue; - } - p = TclWordEnd(p, nested, &commentOK); - if (*p == 0) { - return p; - } - p++; - if (nested) { - if (*p == ']') { - return p; - } - } else { - if (*p == 0) { - return p-1; - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ParseVar -- - * - * Given a string starting with a $ sign, parse off a variable - * name and return its value. - * - * Results: - * The return value is the contents of the variable given by - * the leading characters of string. If termPtr isn't NULL, - * *termPtr gets filled in with the address of the character - * just after the last one in the variable specifier. If the - * variable doesn't exist, then the return value is NULL and - * an error message will be left in interp->result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_ParseVar( - Tcl_Interp *interp, /* Context for looking up variable. */ - char *string, /* String containing variable name. - * First character must be "$". */ - char **termPtr /* If non-NULL, points to word to fill - * in with character just after last - * one in the variable specifier. */ -) -{ - char *name1, *name1End, c, *result; - char *name2; -#define NUM_CHARS 200 - char copyStorage[NUM_CHARS]; - ParseValue pv; - - /* - * There are three cases: - * 1. The $ sign is followed by an open curly brace. Then the variable - * name is everything up to the next close curly brace, and the - * variable is a scalar variable. - * 2. The $ sign is not followed by an open curly brace. Then the - * variable name is everything up to the next character that isn't - * a letter, digit, or underscore. If the following character is an - * open parenthesis, then the information between parentheses is - * the array element name, which can include any of the substitutions - * permissible between quotes. - * 3. The $ sign is followed by something that isn't a letter, digit, - * or underscore: in this case, there is no variable name, and "$" - * is returned. - */ - - name2 = NULL; - string++; - if (*string == '{') { - string++; - name1 = string; - while (*string != '}') { - if (*string == 0) { - Tcl_SetResult(interp, "missing close-brace for variable name", - TCL_STATIC); - if (termPtr != 0) { - *termPtr = string; - } - return NULL; - } - string++; - } - name1End = string; - string++; - } else { - name1 = string; - while (isalnum(UCHAR(*string)) || (*string == '_')) { - string++; - } - if (string == name1) { - if (termPtr != 0) { - *termPtr = string; - } - return "$"; - } - name1End = string; - if (*string == '(') { - char *end; - - /* - * Perform substitutions on the array element name, just as - * is done for quotes. - */ - - pv.buffer = pv.next = copyStorage; - pv.end = copyStorage + NUM_CHARS - 1; - pv.expandProc = TclExpandParseValue; - pv.clientData = (ClientData) NULL; - if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv) - != TCL_OK) { - char msg[200]; - int length; - - length = string-name1; - if (length > 100) { - length = 100; - } - sprintf(msg, "\n (parsing index for array \"%.*s\")", - length, name1); - Tcl_AddErrorInfo(interp, msg); - result = NULL; - name2 = pv.buffer; - if (termPtr != 0) { - *termPtr = end; - } - goto done; - } - Tcl_ResetResult(interp); - string = end; - name2 = pv.buffer; - } - } - if (termPtr != 0) { - *termPtr = string; - } - - if (((Interp *) interp)->noEval) { - return ""; - } - c = *name1End; - *name1End = 0; - result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG); - *name1End = c; - - done: - if ((name2 != NULL) && (pv.buffer != copyStorage)) { - ckfree(pv.buffer); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CommandComplete -- - * - * Given a partial or complete Tcl command, this procedure - * determines whether the command is complete in the sense - * of having matched braces and quotes and brackets. - * - * Results: - * 1 is returned if the command is complete, 0 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_CommandComplete( - char *cmd /* Command to check. */ -) -{ - char *p; - - if (*cmd == 0) { - return 1; - } - p = ScriptEnd(cmd, 0); - return (*p != 0); -} diff --git a/cde/programs/dtdocbook/tcl/tclPkg.c b/cde/programs/dtdocbook/tcl/tclPkg.c deleted file mode 100644 index d6fa47ac..00000000 --- a/cde/programs/dtdocbook/tcl/tclPkg.c +++ /dev/null @@ -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; - } -} diff --git a/cde/programs/dtdocbook/tcl/tclPort.h b/cde/programs/dtdocbook/tcl/tclPort.h deleted file mode 100644 index 7b830ff5..00000000 --- a/cde/programs/dtdocbook/tcl/tclPort.h +++ /dev/null @@ -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 */ diff --git a/cde/programs/dtdocbook/tcl/tclPosixStr.c b/cde/programs/dtdocbook/tcl/tclPosixStr.c deleted file mode 100644 index 47176b7c..00000000 --- a/cde/programs/dtdocbook/tcl/tclPosixStr.c +++ /dev/null @@ -1,1200 +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: tclPosixStr.c /main/3 1998/04/06 13:37:12 mgreess $ */ -/* - * tclPosixStr.c -- - * - * This file contains procedures that generate strings - * corresponding to various POSIX-related codes, such - * as errno and signals. - * - * 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: @(#) tclPosixStr.c 1.30 96/02/08 16:33:34 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - *---------------------------------------------------------------------- - * - * Tcl_ErrnoId -- - * - * Return a textual identifier for the current errno value. - * - * Results: - * This procedure returns a machine-readable textual identifier - * that corresponds to the current errno value (e.g. "EPERM"). - * The identifier is the same as the #define name in errno.h. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_ErrnoId(void) -{ - switch (errno) { -#ifdef E2BIG - case E2BIG: return "E2BIG"; -#endif -#ifdef EACCES - case EACCES: return "EACCES"; -#endif -#ifdef EADDRINUSE - case EADDRINUSE: return "EADDRINUSE"; -#endif -#ifdef EADDRNOTAVAIL - case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; -#endif -#ifdef EADV - case EADV: return "EADV"; -#endif -#ifdef EAFNOSUPPORT - case EAFNOSUPPORT: return "EAFNOSUPPORT"; -#endif -#ifdef EAGAIN - case EAGAIN: return "EAGAIN"; -#endif -#ifdef EALIGN - case EALIGN: return "EALIGN"; -#endif -#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) - case EALREADY: return "EALREADY"; -#endif -#ifdef EBADE - case EBADE: return "EBADE"; -#endif -#ifdef EBADF - case EBADF: return "EBADF"; -#endif -#ifdef EBADFD - case EBADFD: return "EBADFD"; -#endif -#ifdef EBADMSG - case EBADMSG: return "EBADMSG"; -#endif -#ifdef EBADR - case EBADR: return "EBADR"; -#endif -#ifdef EBADRPC - case EBADRPC: return "EBADRPC"; -#endif -#ifdef EBADRQC - case EBADRQC: return "EBADRQC"; -#endif -#ifdef EBADSLT - case EBADSLT: return "EBADSLT"; -#endif -#ifdef EBFONT - case EBFONT: return "EBFONT"; -#endif -#ifdef EBUSY - case EBUSY: return "EBUSY"; -#endif -#ifdef ECHILD - case ECHILD: return "ECHILD"; -#endif -#ifdef ECHRNG - case ECHRNG: return "ECHRNG"; -#endif -#ifdef ECOMM - case ECOMM: return "ECOMM"; -#endif -#ifdef ECONNABORTED - case ECONNABORTED: return "ECONNABORTED"; -#endif -#ifdef ECONNREFUSED - case ECONNREFUSED: return "ECONNREFUSED"; -#endif -#ifdef ECONNRESET - case ECONNRESET: return "ECONNRESET"; -#endif -#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) - case EDEADLK: return "EDEADLK"; -#endif -#if defined(EDEADLOCK) && (EDEADLOCK != EDEADLK) - case EDEADLOCK: return "EDEADLOCK"; -#endif -#ifdef EDESTADDRREQ - case EDESTADDRREQ: return "EDESTADDRREQ"; -#endif -#ifdef EDIRTY - case EDIRTY: return "EDIRTY"; -#endif -#ifdef EDOM - case EDOM: return "EDOM"; -#endif -#ifdef EDOTDOT - case EDOTDOT: return "EDOTDOT"; -#endif -#ifdef EDQUOT - case EDQUOT: return "EDQUOT"; -#endif -#ifdef EDUPPKG - case EDUPPKG: return "EDUPPKG"; -#endif -#ifdef EEXIST - case EEXIST: return "EEXIST"; -#endif -#ifdef EFAULT - case EFAULT: return "EFAULT"; -#endif -#ifdef EFBIG - case EFBIG: return "EFBIG"; -#endif -#ifdef EHOSTDOWN - case EHOSTDOWN: return "EHOSTDOWN"; -#endif -#ifdef EHOSTUNREACH - case EHOSTUNREACH: return "EHOSTUNREACH"; -#endif -#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) - case EIDRM: return "EIDRM"; -#endif -#ifdef EINIT - case EINIT: return "EINIT"; -#endif -#ifdef EINPROGRESS - case EINPROGRESS: return "EINPROGRESS"; -#endif -#ifdef EINTR - case EINTR: return "EINTR"; -#endif -#ifdef EINVAL - case EINVAL: return "EINVAL"; -#endif -#ifdef EIO - case EIO: return "EIO"; -#endif -#ifdef EISCONN - case EISCONN: return "EISCONN"; -#endif -#ifdef EISDIR - case EISDIR: return "EISDIR"; -#endif -#ifdef EISNAME - case EISNAM: return "EISNAM"; -#endif -#ifdef ELBIN - case ELBIN: return "ELBIN"; -#endif -#ifdef EL2HLT - case EL2HLT: return "EL2HLT"; -#endif -#ifdef EL2NSYNC - case EL2NSYNC: return "EL2NSYNC"; -#endif -#ifdef EL3HLT - case EL3HLT: return "EL3HLT"; -#endif -#ifdef EL3RST - case EL3RST: return "EL3RST"; -#endif -#ifdef ELIBACC - case ELIBACC: return "ELIBACC"; -#endif -#ifdef ELIBBAD - case ELIBBAD: return "ELIBBAD"; -#endif -#ifdef ELIBEXEC - case ELIBEXEC: return "ELIBEXEC"; -#endif -#ifdef ELIBMAX - case ELIBMAX: return "ELIBMAX"; -#endif -#ifdef ELIBSCN - case ELIBSCN: return "ELIBSCN"; -#endif -#ifdef ELNRNG - case ELNRNG: return "ELNRNG"; -#endif -#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) - case ELOOP: return "ELOOP"; -#endif -#ifdef EMFILE - case EMFILE: return "EMFILE"; -#endif -#ifdef EMLINK - case EMLINK: return "EMLINK"; -#endif -#ifdef EMSGSIZE - case EMSGSIZE: return "EMSGSIZE"; -#endif -#ifdef EMULTIHOP - case EMULTIHOP: return "EMULTIHOP"; -#endif -#ifdef ENAMETOOLONG - case ENAMETOOLONG: return "ENAMETOOLONG"; -#endif -#ifdef ENAVAIL - case ENAVAIL: return "ENAVAIL"; -#endif -#ifdef ENET - case ENET: return "ENET"; -#endif -#ifdef ENETDOWN - case ENETDOWN: return "ENETDOWN"; -#endif -#ifdef ENETRESET - case ENETRESET: return "ENETRESET"; -#endif -#ifdef ENETUNREACH - case ENETUNREACH: return "ENETUNREACH"; -#endif -#ifdef ENFILE - case ENFILE: return "ENFILE"; -#endif -#ifdef ENOANO - case ENOANO: return "ENOANO"; -#endif -#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) - case ENOBUFS: return "ENOBUFS"; -#endif -#ifdef ENOCSI - case ENOCSI: return "ENOCSI"; -#endif -#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) - case ENODATA: return "ENODATA"; -#endif -#ifdef ENODEV - case ENODEV: return "ENODEV"; -#endif -#ifdef ENOENT - case ENOENT: return "ENOENT"; -#endif -#ifdef ENOEXEC - case ENOEXEC: return "ENOEXEC"; -#endif -#ifdef ENOLCK - case ENOLCK: return "ENOLCK"; -#endif -#ifdef ENOLINK - case ENOLINK: return "ENOLINK"; -#endif -#ifdef ENOMEM - case ENOMEM: return "ENOMEM"; -#endif -#ifdef ENOMSG - case ENOMSG: return "ENOMSG"; -#endif -#ifdef ENONET - case ENONET: return "ENONET"; -#endif -#ifdef ENOPKG - case ENOPKG: return "ENOPKG"; -#endif -#ifdef ENOPROTOOPT - case ENOPROTOOPT: return "ENOPROTOOPT"; -#endif -#ifdef ENOSPC - case ENOSPC: return "ENOSPC"; -#endif -#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) - case ENOSR: return "ENOSR"; -#endif -#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) - case ENOSTR: return "ENOSTR"; -#endif -#ifdef ENOSYM - case ENOSYM: return "ENOSYM"; -#endif -#ifdef ENOSYS - case ENOSYS: return "ENOSYS"; -#endif -#ifdef ENOTBLK - case ENOTBLK: return "ENOTBLK"; -#endif -#ifdef ENOTCONN - case ENOTCONN: return "ENOTCONN"; -#endif -#ifdef ENOTDIR - case ENOTDIR: return "ENOTDIR"; -#endif -#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) - case ENOTEMPTY: return "ENOTEMPTY"; -#endif -#ifdef ENOTNAM - case ENOTNAM: return "ENOTNAM"; -#endif -#ifdef ENOTSOCK - case ENOTSOCK: return "ENOTSOCK"; -#endif -#ifdef ENOTSUP - case ENOTSUP: return "ENOTSUP"; -#endif -#ifdef ENOTTY - case ENOTTY: return "ENOTTY"; -#endif -#ifdef ENOTUNIQ - case ENOTUNIQ: return "ENOTUNIQ"; -#endif -#ifdef ENXIO - case ENXIO: return "ENXIO"; -#endif -#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (EOPNOTSUPP != ENOTSUP)) - case EOPNOTSUPP: return "EOPNOTSUPP"; -#endif -#ifdef EPERM - case EPERM: return "EPERM"; -#endif -#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) - case EPFNOSUPPORT: return "EPFNOSUPPORT"; -#endif -#ifdef EPIPE - case EPIPE: return "EPIPE"; -#endif -#ifdef EPROCLIM - case EPROCLIM: return "EPROCLIM"; -#endif -#ifdef EPROCUNAVAIL - case EPROCUNAVAIL: return "EPROCUNAVAIL"; -#endif -#ifdef EPROGMISMATCH - case EPROGMISMATCH: return "EPROGMISMATCH"; -#endif -#ifdef EPROGUNAVAIL - case EPROGUNAVAIL: return "EPROGUNAVAIL"; -#endif -#ifdef EPROTO - case EPROTO: return "EPROTO"; -#endif -#ifdef EPROTONOSUPPORT - case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; -#endif -#ifdef EPROTOTYPE - case EPROTOTYPE: return "EPROTOTYPE"; -#endif -#ifdef ERANGE - case ERANGE: return "ERANGE"; -#endif -#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) - case EREFUSED: return "EREFUSED"; -#endif -#ifdef EREMCHG - case EREMCHG: return "EREMCHG"; -#endif -#ifdef EREMDEV - case EREMDEV: return "EREMDEV"; -#endif -#ifdef EREMOTE - case EREMOTE: return "EREMOTE"; -#endif -#ifdef EREMOTEIO - case EREMOTEIO: return "EREMOTEIO"; -#endif -#ifdef EREMOTERELEASE - case EREMOTERELEASE: return "EREMOTERELEASE"; -#endif -#ifdef EROFS - case EROFS: return "EROFS"; -#endif -#ifdef ERPCMISMATCH - case ERPCMISMATCH: return "ERPCMISMATCH"; -#endif -#ifdef ERREMOTE - case ERREMOTE: return "ERREMOTE"; -#endif -#ifdef ESHUTDOWN - case ESHUTDOWN: return "ESHUTDOWN"; -#endif -#ifdef ESOCKTNOSUPPORT - case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; -#endif -#ifdef ESPIPE - case ESPIPE: return "ESPIPE"; -#endif -#ifdef ESRCH - case ESRCH: return "ESRCH"; -#endif -#ifdef ESRMNT - case ESRMNT: return "ESRMNT"; -#endif -#ifdef ESTALE - case ESTALE: return "ESTALE"; -#endif -#ifdef ESUCCESS - case ESUCCESS: return "ESUCCESS"; -#endif -#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) - case ETIME: return "ETIME"; -#endif -#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) - case ETIMEDOUT: return "ETIMEDOUT"; -#endif -#ifdef ETOOMANYREFS - case ETOOMANYREFS: return "ETOOMANYREFS"; -#endif -#ifdef ETXTBSY - case ETXTBSY: return "ETXTBSY"; -#endif -#ifdef EUCLEAN - case EUCLEAN: return "EUCLEAN"; -#endif -#ifdef EUNATCH - case EUNATCH: return "EUNATCH"; -#endif -#ifdef EUSERS - case EUSERS: return "EUSERS"; -#endif -#ifdef EVERSION - case EVERSION: return "EVERSION"; -#endif -#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) - case EWOULDBLOCK: return "EWOULDBLOCK"; -#endif -#ifdef EXDEV - case EXDEV: return "EXDEV"; -#endif -#ifdef EXFULL - case EXFULL: return "EXFULL"; -#endif - } - return "unknown error"; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ErrnoMsg -- - * - * Return a human-readable message corresponding to a given - * errno value. - * - * Results: - * The return value is the standard POSIX error message for - * errno. This procedure is used instead of strerror because - * strerror returns slightly different values on different - * machines (e.g. different capitalizations), which cause - * problems for things such as regression tests. This procedure - * provides messages for most standard errors, then it calls - * strerror for things it doesn't understand. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_ErrnoMsg( - int err /* Error number (such as in errno variable). */ -) -{ - switch (err) { -#ifdef E2BIG - case E2BIG: return "argument list too long"; -#endif -#ifdef EACCES - case EACCES: return "permission denied"; -#endif -#ifdef EADDRINUSE - case EADDRINUSE: return "address already in use"; -#endif -#ifdef EADDRNOTAVAIL - case EADDRNOTAVAIL: return "can't assign requested address"; -#endif -#ifdef EADV - case EADV: return "advertise error"; -#endif -#ifdef EAFNOSUPPORT - case EAFNOSUPPORT: return "address family not supported by protocol family"; -#endif -#ifdef EAGAIN - case EAGAIN: return "resource temporarily unavailable"; -#endif -#ifdef EALIGN - case EALIGN: return "EALIGN"; -#endif -#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) - case EALREADY: return "operation already in progress"; -#endif -#ifdef EBADE - case EBADE: return "bad exchange descriptor"; -#endif -#ifdef EBADF - case EBADF: return "bad file number"; -#endif -#ifdef EBADFD - case EBADFD: return "file descriptor in bad state"; -#endif -#ifdef EBADMSG - case EBADMSG: return "not a data message"; -#endif -#ifdef EBADR - case EBADR: return "bad request descriptor"; -#endif -#ifdef EBADRPC - case EBADRPC: return "RPC structure is bad"; -#endif -#ifdef EBADRQC - case EBADRQC: return "bad request code"; -#endif -#ifdef EBADSLT - case EBADSLT: return "invalid slot"; -#endif -#ifdef EBFONT - case EBFONT: return "bad font file format"; -#endif -#ifdef EBUSY - case EBUSY: return "mount device busy"; -#endif -#ifdef ECHILD - case ECHILD: return "no children"; -#endif -#ifdef ECHRNG - case ECHRNG: return "channel number out of range"; -#endif -#ifdef ECOMM - case ECOMM: return "communication error on send"; -#endif -#ifdef ECONNABORTED - case ECONNABORTED: return "software caused connection abort"; -#endif -#ifdef ECONNREFUSED - case ECONNREFUSED: return "connection refused"; -#endif -#ifdef ECONNRESET - case ECONNRESET: return "connection reset by peer"; -#endif -#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) - case EDEADLK: return "resource deadlock avoided"; -#endif -#if defined(EDEADLOCK) && (EDEADLOCK != EDEADLK) - case EDEADLOCK: return "resource deadlock avoided"; -#endif -#ifdef EDESTADDRREQ - case EDESTADDRREQ: return "destination address required"; -#endif -#ifdef EDIRTY - case EDIRTY: return "mounting a dirty fs w/o force"; -#endif -#ifdef EDOM - case EDOM: return "math argument out of range"; -#endif -#ifdef EDOTDOT - case EDOTDOT: return "cross mount point"; -#endif -#ifdef EDQUOT - case EDQUOT: return "disk quota exceeded"; -#endif -#ifdef EDUPPKG - case EDUPPKG: return "duplicate package name"; -#endif -#ifdef EEXIST - case EEXIST: return "file already exists"; -#endif -#ifdef EFAULT - case EFAULT: return "bad address in system call argument"; -#endif -#ifdef EFBIG - case EFBIG: return "file too large"; -#endif -#ifdef EHOSTDOWN - case EHOSTDOWN: return "host is down"; -#endif -#ifdef EHOSTUNREACH - case EHOSTUNREACH: return "host is unreachable"; -#endif -#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) - case EIDRM: return "identifier removed"; -#endif -#ifdef EINIT - case EINIT: return "initialization error"; -#endif -#ifdef EINPROGRESS - case EINPROGRESS: return "operation now in progress"; -#endif -#ifdef EINTR - case EINTR: return "interrupted system call"; -#endif -#ifdef EINVAL - case EINVAL: return "invalid argument"; -#endif -#ifdef EIO - case EIO: return "I/O error"; -#endif -#ifdef EISCONN - case EISCONN: return "socket is already connected"; -#endif -#ifdef EISDIR - case EISDIR: return "illegal operation on a directory"; -#endif -#ifdef EISNAME - case EISNAM: return "is a name file"; -#endif -#ifdef ELBIN - case ELBIN: return "ELBIN"; -#endif -#ifdef EL2HLT - case EL2HLT: return "level 2 halted"; -#endif -#ifdef EL2NSYNC - case EL2NSYNC: return "level 2 not synchronized"; -#endif -#ifdef EL3HLT - case EL3HLT: return "level 3 halted"; -#endif -#ifdef EL3RST - case EL3RST: return "level 3 reset"; -#endif -#ifdef ELIBACC - case ELIBACC: return "can not access a needed shared library"; -#endif -#ifdef ELIBBAD - case ELIBBAD: return "accessing a corrupted shared library"; -#endif -#ifdef ELIBEXEC - case ELIBEXEC: return "can not exec a shared library directly"; -#endif -#ifdef ELIBMAX - case ELIBMAX: return - "attempting to link in more shared libraries than system limit"; -#endif -#ifdef ELIBSCN - case ELIBSCN: return ".lib section in a.out corrupted"; -#endif -#ifdef ELNRNG - case ELNRNG: return "link number out of range"; -#endif -#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) - case ELOOP: return "too many levels of symbolic links"; -#endif -#ifdef EMFILE - case EMFILE: return "too many open files"; -#endif -#ifdef EMLINK - case EMLINK: return "too many links"; -#endif -#ifdef EMSGSIZE - case EMSGSIZE: return "message too long"; -#endif -#ifdef EMULTIHOP - case EMULTIHOP: return "multihop attempted"; -#endif -#ifdef ENAMETOOLONG - case ENAMETOOLONG: return "file name too long"; -#endif -#ifdef ENAVAIL - case ENAVAIL: return "not available"; -#endif -#ifdef ENET - case ENET: return "ENET"; -#endif -#ifdef ENETDOWN - case ENETDOWN: return "network is down"; -#endif -#ifdef ENETRESET - case ENETRESET: return "network dropped connection on reset"; -#endif -#ifdef ENETUNREACH - case ENETUNREACH: return "network is unreachable"; -#endif -#ifdef ENFILE - case ENFILE: return "file table overflow"; -#endif -#ifdef ENOANO - case ENOANO: return "anode table overflow"; -#endif -#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) - case ENOBUFS: return "no buffer space available"; -#endif -#ifdef ENOCSI - case ENOCSI: return "no CSI structure available"; -#endif -#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) - case ENODATA: return "no data available"; -#endif -#ifdef ENODEV - case ENODEV: return "no such device"; -#endif -#ifdef ENOENT - case ENOENT: return "no such file or directory"; -#endif -#ifdef ENOEXEC - case ENOEXEC: return "exec format error"; -#endif -#ifdef ENOLCK - case ENOLCK: return "no locks available"; -#endif -#ifdef ENOLINK - case ENOLINK: return "link has be severed"; -#endif -#ifdef ENOMEM - case ENOMEM: return "not enough memory"; -#endif -#ifdef ENOMSG - case ENOMSG: return "no message of desired type"; -#endif -#ifdef ENONET - case ENONET: return "machine is not on the network"; -#endif -#ifdef ENOPKG - case ENOPKG: return "package not installed"; -#endif -#ifdef ENOPROTOOPT - case ENOPROTOOPT: return "bad proocol option"; -#endif -#ifdef ENOSPC - case ENOSPC: return "no space left on device"; -#endif -#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) - case ENOSR: return "out of stream resources"; -#endif -#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) - case ENOSTR: return "not a stream device"; -#endif -#ifdef ENOSYM - case ENOSYM: return "unresolved symbol name"; -#endif -#ifdef ENOSYS - case ENOSYS: return "function not implemented"; -#endif -#ifdef ENOTBLK - case ENOTBLK: return "block device required"; -#endif -#ifdef ENOTCONN - case ENOTCONN: return "socket is not connected"; -#endif -#ifdef ENOTDIR - case ENOTDIR: return "not a directory"; -#endif -#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) - case ENOTEMPTY: return "directory not empty"; -#endif -#ifdef ENOTNAM - case ENOTNAM: return "not a name file"; -#endif -#ifdef ENOTSOCK - case ENOTSOCK: return "socket operation on non-socket"; -#endif -#ifdef ENOTSUP - case ENOTSUP: return "operation not supported"; -#endif -#ifdef ENOTTY - case ENOTTY: return "inappropriate device for ioctl"; -#endif -#ifdef ENOTUNIQ - case ENOTUNIQ: return "name not unique on network"; -#endif -#ifdef ENXIO - case ENXIO: return "no such device or address"; -#endif -#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (EOPNOTSUPP != ENOTSUP)) - case EOPNOTSUPP: return "operation not supported on socket"; -#endif -#ifdef EPERM - case EPERM: return "not owner"; -#endif -#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) - case EPFNOSUPPORT: return "protocol family not supported"; -#endif -#ifdef EPIPE - case EPIPE: return "broken pipe"; -#endif -#ifdef EPROCLIM - case EPROCLIM: return "too many processes"; -#endif -#ifdef EPROCUNAVAIL - case EPROCUNAVAIL: return "bad procedure for program"; -#endif -#ifdef EPROGMISMATCH - case EPROGMISMATCH: return "program version wrong"; -#endif -#ifdef EPROGUNAVAIL - case EPROGUNAVAIL: return "RPC program not available"; -#endif -#ifdef EPROTO - case EPROTO: return "protocol error"; -#endif -#ifdef EPROTONOSUPPORT - case EPROTONOSUPPORT: return "protocol not supported"; -#endif -#ifdef EPROTOTYPE - case EPROTOTYPE: return "protocol wrong type for socket"; -#endif -#ifdef ERANGE - case ERANGE: return "math result unrepresentable"; -#endif -#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) - case EREFUSED: return "EREFUSED"; -#endif -#ifdef EREMCHG - case EREMCHG: return "remote address changed"; -#endif -#ifdef EREMDEV - case EREMDEV: return "remote device"; -#endif -#ifdef EREMOTE - case EREMOTE: return "pathname hit remote file system"; -#endif -#ifdef EREMOTEIO - case EREMOTEIO: return "remote i/o error"; -#endif -#ifdef EREMOTERELEASE - case EREMOTERELEASE: return "EREMOTERELEASE"; -#endif -#ifdef EROFS - case EROFS: return "read-only file system"; -#endif -#ifdef ERPCMISMATCH - case ERPCMISMATCH: return "RPC version is wrong"; -#endif -#ifdef ERREMOTE - case ERREMOTE: return "object is remote"; -#endif -#ifdef ESHUTDOWN - case ESHUTDOWN: return "can't send after socket shutdown"; -#endif -#ifdef ESOCKTNOSUPPORT - case ESOCKTNOSUPPORT: return "socket type not supported"; -#endif -#ifdef ESPIPE - case ESPIPE: return "invalid seek"; -#endif -#ifdef ESRCH - case ESRCH: return "no such process"; -#endif -#ifdef ESRMNT - case ESRMNT: return "srmount error"; -#endif -#ifdef ESTALE - case ESTALE: return "stale remote file handle"; -#endif -#ifdef ESUCCESS - case ESUCCESS: return "Error 0"; -#endif -#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) - case ETIME: return "timer expired"; -#endif -#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) - case ETIMEDOUT: return "connection timed out"; -#endif -#ifdef ETOOMANYREFS - case ETOOMANYREFS: return "too many references: can't splice"; -#endif -#ifdef ETXTBSY - case ETXTBSY: return "text file or pseudo-device busy"; -#endif -#ifdef EUCLEAN - case EUCLEAN: return "structure needs cleaning"; -#endif -#ifdef EUNATCH - case EUNATCH: return "protocol driver not attached"; -#endif -#ifdef EUSERS - case EUSERS: return "too many users"; -#endif -#ifdef EVERSION - case EVERSION: return "version mismatch"; -#endif -#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) - case EWOULDBLOCK: return "operation would block"; -#endif -#ifdef EXDEV - case EXDEV: return "cross-domain link"; -#endif -#ifdef EXFULL - case EXFULL: return "message tables full"; -#endif - default: -#ifdef NO_STRERROR - return "unknown POSIX error"; -#else - return strerror(errno); -#endif - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SignalId -- - * - * Return a textual identifier for a signal number. - * - * Results: - * This procedure returns a machine-readable textual identifier - * that corresponds to sig. The identifier is the same as the - * #define name in signal.h. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_SignalId( - int sig /* Number of signal. */ -) -{ - switch (sig) { -#ifdef SIGABRT - case SIGABRT: return "SIGABRT"; -#endif -#ifdef SIGALRM - case SIGALRM: return "SIGALRM"; -#endif -#ifdef SIGBUS - case SIGBUS: return "SIGBUS"; -#endif -#ifdef SIGCHLD - case SIGCHLD: return "SIGCHLD"; -#endif -#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) - case SIGCLD: return "SIGCLD"; -#endif -#ifdef SIGCONT - case SIGCONT: return "SIGCONT"; -#endif -#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) - case SIGEMT: return "SIGEMT"; -#endif -#ifdef SIGFPE - case SIGFPE: return "SIGFPE"; -#endif -#ifdef SIGHUP - case SIGHUP: return "SIGHUP"; -#endif -#ifdef SIGILL - case SIGILL: return "SIGILL"; -#endif -#ifdef SIGINT - case SIGINT: return "SIGINT"; -#endif -#ifdef SIGIO - case SIGIO: return "SIGIO"; -#endif -#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT)) - case SIGIOT: return "SIGIOT"; -#endif -#ifdef SIGKILL - case SIGKILL: return "SIGKILL"; -#endif -#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) - case SIGLOST: return "SIGLOST"; -#endif -#ifdef SIGPIPE - case SIGPIPE: return "SIGPIPE"; -#endif -#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) - case SIGPOLL: return "SIGPOLL"; -#endif -#ifdef SIGPROF - case SIGPROF: return "SIGPROF"; -#endif -#if defined(SIGPWR) && (SIGPWR != SIGLOST) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) - case SIGPWR: return "SIGPWR"; -#endif -#ifdef SIGQUIT - case SIGQUIT: return "SIGQUIT"; -#endif -#ifdef SIGSEGV - case SIGSEGV: return "SIGSEGV"; -#endif -#ifdef SIGSTOP - case SIGSTOP: return "SIGSTOP"; -#endif -#ifdef SIGSYS - case SIGSYS: return "SIGSYS"; -#endif -#ifdef SIGTERM - case SIGTERM: return "SIGTERM"; -#endif -#ifdef SIGTRAP - case SIGTRAP: return "SIGTRAP"; -#endif -#ifdef SIGTSTP - case SIGTSTP: return "SIGTSTP"; -#endif -#ifdef SIGTTIN - case SIGTTIN: return "SIGTTIN"; -#endif -#ifdef SIGTTOU - case SIGTTOU: return "SIGTTOU"; -#endif -#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) - case SIGURG: return "SIGURG"; -#endif -#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) - case SIGUSR1: return "SIGUSR1"; -#endif -#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) - case SIGUSR2: return "SIGUSR2"; -#endif -#ifdef SIGVTALRM - case SIGVTALRM: return "SIGVTALRM"; -#endif -#ifdef SIGWINCH - case SIGWINCH: return "SIGWINCH"; -#endif -#ifdef SIGXCPU - case SIGXCPU: return "SIGXCPU"; -#endif -#ifdef SIGXFSZ - case SIGXFSZ: return "SIGXFSZ"; -#endif - } - return "unknown signal"; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SignalMsg -- - * - * Return a human-readable message describing a signal. - * - * Results: - * This procedure returns a string describing sig that should - * make sense to a human. It may not be easy for a machine - * to parse. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_SignalMsg( - int sig /* Number of signal. */ -) -{ - switch (sig) { -#ifdef SIGABRT - case SIGABRT: return "SIGABRT"; -#endif -#ifdef SIGALRM - case SIGALRM: return "alarm clock"; -#endif -#ifdef SIGBUS - case SIGBUS: return "bus error"; -#endif -#ifdef SIGCHLD - case SIGCHLD: return "child status changed"; -#endif -#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) - case SIGCLD: return "child status changed"; -#endif -#ifdef SIGCONT - case SIGCONT: return "continue after stop"; -#endif -#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) - case SIGEMT: return "EMT instruction"; -#endif -#ifdef SIGFPE - case SIGFPE: return "floating-point exception"; -#endif -#ifdef SIGHUP - case SIGHUP: return "hangup"; -#endif -#ifdef SIGILL - case SIGILL: return "illegal instruction"; -#endif -#ifdef SIGINT - case SIGINT: return "interrupt"; -#endif -#ifdef SIGIO - case SIGIO: return "input/output possible on file"; -#endif -#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT)) - case SIGIOT: return "IOT instruction"; -#endif -#ifdef SIGKILL - case SIGKILL: return "kill signal"; -#endif -#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) - case SIGLOST: return "resource lost"; -#endif -#ifdef SIGPIPE - case SIGPIPE: return "write on pipe with no readers"; -#endif -#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) - case SIGPOLL: return "input/output possible on file"; -#endif -#ifdef SIGPROF - case SIGPROF: return "profiling alarm"; -#endif -#if defined(SIGPWR) && (SIGPWR != SIGLOST) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) - case SIGPWR: return "power-fail restart"; -#endif -#ifdef SIGQUIT - case SIGQUIT: return "quit signal"; -#endif -#ifdef SIGSEGV - case SIGSEGV: return "segmentation violation"; -#endif -#ifdef SIGSTOP - case SIGSTOP: return "stop"; -#endif -#ifdef SIGSYS - case SIGSYS: return "bad argument to system call"; -#endif -#ifdef SIGTERM - case SIGTERM: return "software termination signal"; -#endif -#ifdef SIGTRAP - case SIGTRAP: return "trace trap"; -#endif -#ifdef SIGTSTP - case SIGTSTP: return "stop signal from tty"; -#endif -#ifdef SIGTTIN - case SIGTTIN: return "background tty read"; -#endif -#ifdef SIGTTOU - case SIGTTOU: return "background tty write"; -#endif -#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) - case SIGURG: return "urgent I/O condition"; -#endif -#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) - case SIGUSR1: return "user-defined signal 1"; -#endif -#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) - case SIGUSR2: return "user-defined signal 2"; -#endif -#ifdef SIGVTALRM - case SIGVTALRM: return "virtual time alarm"; -#endif -#ifdef SIGWINCH - case SIGWINCH: return "window changed"; -#endif -#ifdef SIGXCPU - case SIGXCPU: return "exceeded CPU time limit"; -#endif -#ifdef SIGXFSZ - case SIGXFSZ: return "exceeded file size limit"; -#endif - } - return "unknown signal"; -} diff --git a/cde/programs/dtdocbook/tcl/tclPreserve.c b/cde/programs/dtdocbook/tcl/tclPreserve.c deleted file mode 100644 index 6604b673..00000000 --- a/cde/programs/dtdocbook/tcl/tclPreserve.c +++ /dev/null @@ -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); - } -} diff --git a/cde/programs/dtdocbook/tcl/tclProc.c b/cde/programs/dtdocbook/tcl/tclProc.c deleted file mode 100644 index 85664b34..00000000 --- a/cde/programs/dtdocbook/tcl/tclProc.c +++ /dev/null @@ -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; -} diff --git a/cde/programs/dtdocbook/tcl/tclRegexp.h b/cde/programs/dtdocbook/tcl/tclRegexp.h deleted file mode 100644 index ea020259..00000000 --- a/cde/programs/dtdocbook/tcl/tclRegexp.h +++ /dev/null @@ -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 */ diff --git a/cde/programs/dtdocbook/tcl/tclUnixChan.c b/cde/programs/dtdocbook/tcl/tclUnixChan.c deleted file mode 100644 index 6c360518..00000000 --- a/cde/programs/dtdocbook/tcl/tclUnixChan.c +++ /dev/null @@ -1,1878 +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: tclUnixChan.c /main/3 1996/10/03 17:18:13 drk $ */ -/* - * tclUnixChan.c - * - * Common channel driver for Unix channels based on files, command - * pipes and TCP sockets. - * - * 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: @(#) tclUnixChan.c 1.161 96/04/18 08:28:54 - */ - -#include "tclInt.h" /* Internal definitions for Tcl. */ -#include "tclPort.h" /* Portability features for Tcl. */ - -/* - * This structure describes per-instance state of a pipe based channel. - */ - -typedef struct PipeState { - Tcl_File readFile; /* Output from pipe. */ - Tcl_File writeFile; /* Input to pipe. */ - Tcl_File errorFile; /* Error output from pipe. */ - int numPids; /* How many processes are attached to this pipe? */ - pid_t *pidPtr; /* The process IDs themselves. Allocated by - * the creator of the pipe. */ -} PipeState; - -/* - * This structure describes per-instance state of a tcp based channel. - */ - -typedef struct TcpState { - int flags; /* ORed combination of the - * bitfields defined below. */ - Tcl_File sock; /* The socket itself. */ - Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ - ClientData acceptProcData; /* The data for the accept proc. */ -} TcpState; - -/* - * These bits may be ORed together into the "flags" field of a TcpState - * structure. - */ - -#define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */ -#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ - -/* - * The following defines how much buffer space the kernel should maintain - * for a socket. - */ - -#define SOCKET_BUFSIZE 4096 - -/* - * Static routines for this file: - */ - -static int CommonBlockModeProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_File inFile, - Tcl_File outFile, int mode)); -static TcpState * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp, - int port, char *host, int server, - char *myaddr, int myport, int async)); -static int CreateSocketAddress _ANSI_ARGS_( - (struct sockaddr_in *sockaddrPtr, - char *host, int port)); -static int FileCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, Tcl_File inFile, - Tcl_File outFile)); -static int FilePipeInputProc _ANSI_ARGS_((ClientData instanceData, - Tcl_File inFile, char *buf, int toRead, - int *errorCode)); -static int FilePipeOutputProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_File outFile, - char *buf, int toWrite, int *errorCode)); -static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, - Tcl_File inFile, Tcl_File outFile, long offset, - int mode, int *errorCode)); -static int PipeCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, Tcl_File inFile, - Tcl_File outFile)); -static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); -static int TcpBlockModeProc _ANSI_ARGS_((ClientData data, - Tcl_File inFile, Tcl_File outFile, int mode)); -static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, Tcl_File inFile, - Tcl_File outFile)); -static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData, - char *optionName, Tcl_DString *dsPtr)); -static int TcpInputProc _ANSI_ARGS_((ClientData instanceData, - Tcl_File infile, char *buf, int toRead, - int *errorCode)); -static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData, - Tcl_File outFile, char *buf, int toWrite, - int *errorCode)); -static int WaitForConnect _ANSI_ARGS_((TcpState *statePtr, - Tcl_File fileToWaitFor, int *errorCodePtr)); - -/* - * This structure describes the channel type structure for file based IO: - */ - -static Tcl_ChannelType fileChannelType = { - "file", /* Type name. */ - CommonBlockModeProc, /* Set blocking/nonblocking mode.*/ - FileCloseProc, /* Close proc. */ - FilePipeInputProc, /* Input proc. */ - FilePipeOutputProc, /* Output proc. */ - FileSeekProc, /* Seek proc. */ - NULL, /* Set option proc. */ - NULL, /* Get option proc. */ -}; - -/* - * This structure describes the channel type structure for command pipe - * based IO: - */ - -static Tcl_ChannelType pipeChannelType = { - "pipe", /* Type name. */ - CommonBlockModeProc, /* Set blocking/nonblocking mode.*/ - PipeCloseProc, /* Close proc. */ - FilePipeInputProc, /* Input proc. */ - FilePipeOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - NULL, /* Set option proc. */ - NULL, /* Get option proc. */ -}; - -/* - * This structure describes the channel type structure for TCP socket - * based IO: - */ - -static Tcl_ChannelType tcpChannelType = { - "tcp", /* Type name. */ - TcpBlockModeProc, /* Set blocking/nonblocking mode.*/ - TcpCloseProc, /* Close proc. */ - TcpInputProc, /* Input proc. */ - TcpOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - NULL, /* Set option proc. */ - TcpGetOptionProc, /* Get option proc. */ -}; - -/* - *---------------------------------------------------------------------- - * - * CommonBlockModeProc -- - * - * Helper procedure to set blocking and nonblocking modes on a - * channel. Invoked either by generic IO level code or by other - * channel drivers after doing channel-type-specific inialization. - * - * Results: - * 0 if successful, errno when failed. - * - * Side effects: - * Sets the device into blocking or non-blocking mode. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -CommonBlockModeProc( - ClientData instanceData, /* Unused. */ - Tcl_File inFile, Tcl_File outFile, /* Input, output files for channel. */ - int mode /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -) -{ - int curStatus; - int fd; - - if (inFile != NULL) { - fd = (int) (intptr_t) Tcl_GetFileInfo(inFile, NULL); - curStatus = fcntl(fd, F_GETFL); - if (mode == TCL_MODE_BLOCKING) { - curStatus &= (~(O_NONBLOCK)); - } else { - curStatus |= O_NONBLOCK; - } - if (fcntl(fd, F_SETFL, curStatus) < 0) { - return errno; - } - curStatus = fcntl(fd, F_GETFL); - } - if (outFile != NULL) { - fd = (int) (intptr_t) Tcl_GetFileInfo(outFile, NULL); - curStatus = fcntl(fd, F_GETFL); - if (mode == TCL_MODE_BLOCKING) { - curStatus &= (~(O_NONBLOCK)); - } else { - curStatus |= O_NONBLOCK; - } - if (fcntl(fd, F_SETFL, curStatus) < 0) { - return errno; - } - } - - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * FilePipeInputProc -- - * - * This procedure is invoked from the generic IO level to read - * input from a file or command pipeline channel. - * - * Results: - * The number of bytes read is returned or -1 on error. An output - * argument contains a POSIX error code if an error occurs, or zero. - * - * Side effects: - * Reads input from the input device of the channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -FilePipeInputProc( - ClientData instanceData, /* Unused. */ - Tcl_File inFile, /* Input device for channel. */ - char *buf, /* Where to store data read. */ - int toRead, /* How much space is available - * in the buffer? */ - int *errorCodePtr /* Where to store error code. */ -) -{ - int fd; /* The OS handle for reading. */ - int bytesRead; /* How many bytes were actually - * read from the input device? */ - - *errorCodePtr = 0; - fd = (int) (intptr_t) Tcl_GetFileInfo(inFile, NULL); - - /* - * Assume there is always enough input available. This will block - * appropriately, and read will unblock as soon as a short read is - * possible, if the channel is in blocking mode. If the channel is - * nonblocking, the read will never block. - */ - - bytesRead = read(fd, buf, (size_t) toRead); - if (bytesRead > -1) { - return bytesRead; - } - *errorCodePtr = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * FilePipeOutputProc-- - * - * This procedure is invoked from the generic IO level to write - * output to a file or command pipeline channel. - * - * Results: - * The number of bytes written is returned or -1 on error. An - * output argument contains a POSIX error code if an error occurred, - * or zero. - * - * Side effects: - * Writes output on the output device of the channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -FilePipeOutputProc( - ClientData instanceData, /* Unused. */ - Tcl_File outFile, /* Output device for channel. */ - char *buf, /* The data buffer. */ - int toWrite, /* How many bytes to write? */ - int *errorCodePtr /* Where to store error code. */ -) -{ - int written; - int fd; - - *errorCodePtr = 0; - fd = (int) (intptr_t) Tcl_GetFileInfo(outFile, NULL); - written = write(fd, buf, (size_t) toWrite); - if (written > -1) { - return written; - } - *errorCodePtr = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * FileCloseProc -- - * - * This procedure is called from the generic IO level to perform - * channel-type-specific cleanup when a file based channel is closed. - * - * Results: - * 0 if successful, errno if failed. - * - * Side effects: - * Closes the device of the channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -FileCloseProc( - ClientData instanceData, /* Unused. */ - Tcl_Interp *interp, /* For error reporting - unused. */ - Tcl_File inFile, /* Input file to close. */ - Tcl_File outFile /* Output file to close. */ -) -{ - int fd, errorCode = 0; - - if (inFile != NULL) { - - /* - * Check for read/write file so we only close it once. - */ - - if (inFile == outFile) { - outFile = NULL; - } - fd = (int) (intptr_t) Tcl_GetFileInfo(inFile, NULL); - Tcl_FreeFile(inFile); - - if (close(fd) < 0) { - errorCode = errno; - } - } - - if (outFile != NULL) { - fd = (int) (intptr_t) Tcl_GetFileInfo(outFile, NULL); - Tcl_FreeFile(outFile); - if ((close(fd) < 0) && (errorCode == 0)) { - errorCode = errno; - } - } - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * FileSeekProc -- - * - * This procedure is called by the generic IO level to move the - * access point in a file based channel. - * - * Results: - * -1 if failed, the new position if successful. An output - * argument contains the POSIX error code if an error occurred, - * or zero. - * - * Side effects: - * Moves the location at which the channel will be accessed in - * future operations. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -FileSeekProc( - ClientData instanceData, /* Unused. */ - Tcl_File inFile, Tcl_File outFile, /* Input and output - * files for channel. */ - long offset, /* Offset to seek to. */ - int mode, /* Relative to where - * should we seek? Can be - * one of SEEK_START, - * SEEK_SET or SEEK_END. */ - int *errorCodePtr /* To store error code. */ -) -{ - int newLoc; - int fd; - - *errorCodePtr = 0; - if (inFile != (Tcl_File) NULL) { - fd = (int) (intptr_t) Tcl_GetFileInfo(inFile, NULL); - } else if (outFile != (Tcl_File) NULL) { - fd = (int) (intptr_t) Tcl_GetFileInfo(outFile, NULL); - } else { - *errorCodePtr = EFAULT; - return -1; - } - newLoc = lseek(fd, offset, mode); - if (newLoc > -1) { - return newLoc; - } - *errorCodePtr = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetAndDetachPids -- - * - * This procedure is invoked in the generic implementation of a - * background "exec" (An exec when invoked with a terminating "&") - * to store a list of the PIDs for processes in a command pipeline - * in interp->result and to detach the processes. - * - * Results: - * None. - * - * Side effects: - * Modifies interp->result. Detaches processes. - * - *---------------------------------------------------------------------- - */ - -void -TclGetAndDetachPids( - Tcl_Interp *interp, - Tcl_Channel chan -) -{ - PipeState *pipePtr; - Tcl_ChannelType *chanTypePtr; - int i; - char buf[20]; - - /* - * Punt if the channel is not a command channel. - */ - - chanTypePtr = Tcl_GetChannelType(chan); - if (chanTypePtr != &pipeChannelType) { - return; - } - - pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); - for (i = 0; i < pipePtr->numPids; i++) { - sprintf(buf, "%ld", (long)pipePtr->pidPtr[i]); - Tcl_AppendElement(interp, buf); - Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); - } - if (pipePtr->numPids > 0) { - ckfree((char *) pipePtr->pidPtr); - pipePtr->numPids = 0; - } -} - -/* - *---------------------------------------------------------------------- - * - * PipeCloseProc -- - * - * This procedure is invoked by the generic IO level to perform - * channel-type-specific cleanup when a command pipeline channel - * is closed. - * - * Results: - * 0 on success, errno otherwise. - * - * Side effects: - * Closes the command pipeline channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -PipeCloseProc( - ClientData instanceData, /* The pipe to close. */ - Tcl_Interp *interp, /* For error reporting. */ - Tcl_File inFile, Tcl_File outFile /* Unused. */ -) -{ - PipeState *pipePtr; - Tcl_Channel errChan; - int fd, errorCode, result; - - errorCode = 0; - pipePtr = (PipeState *) instanceData; - if (pipePtr->readFile != NULL) { - fd = (int) (intptr_t) Tcl_GetFileInfo(pipePtr->readFile, NULL); - Tcl_FreeFile(pipePtr->readFile); - if (close(fd) < 0) { - errorCode = errno; - } - } - if (pipePtr->writeFile != NULL) { - fd = (int) (intptr_t) Tcl_GetFileInfo(pipePtr->writeFile, NULL); - Tcl_FreeFile(pipePtr->writeFile); - if ((close(fd) < 0) && (errorCode == 0)) { - errorCode = errno; - } - } - - /* - * Wrap the error file into a channel and give it to the cleanup - * routine. - */ - - if (pipePtr->errorFile != NULL) { - errChan = Tcl_CreateChannel(&fileChannelType, "pipeError", - pipePtr->errorFile, NULL, NULL); - } else { - errChan = NULL; - } - result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, - errChan); - if (pipePtr->numPids != 0) { - ckfree((char *) pipePtr->pidPtr); - } - ckfree((char *) pipePtr); - if (errorCode == 0) { - return result; - } - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenFileChannel -- - * - * Open an file based channel on Unix systems. - * - * Results: - * The new channel or NULL. If NULL, the output argument - * errorCodePtr is set to a POSIX error and an error message is - * left in interp->result if interp is not NULL. - * - * Side effects: - * May open the channel and may cause creation of a file on the - * file system. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_OpenFileChannel( - Tcl_Interp *interp, /* Interpreter for error reporting; - * can be NULL. */ - char *fileName, /* Name of file to open. */ - char *modeString, /* A list of POSIX open modes or - * a string such as "rw". */ - int permissions /* If the open involves creating a - * file, with what modes to create - * it? */ -) -{ - int fd, seekFlag, mode, channelPermissions; - Tcl_File file; - Tcl_Channel chan; - char *nativeName, channelName[20]; - Tcl_DString buffer; - - mode = TclGetOpenMode(interp, modeString, &seekFlag); - if (mode == -1) { - return NULL; - } - switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { - case O_RDONLY: - channelPermissions = TCL_READABLE; - break; - case O_WRONLY: - channelPermissions = TCL_WRITABLE; - break; - case O_RDWR: - channelPermissions = (TCL_READABLE | TCL_WRITABLE); - break; - default: - /* - * This may occur if modeString was "", for example. - */ - panic("Tcl_OpenFileChannel: invalid mode value"); - return NULL; - } - - nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (nativeName == NULL) { - return NULL; - } - fd = open(nativeName, mode, permissions); - - /* - * If nativeName is not NULL, the buffer is valid and we must free - * the storage. - */ - - Tcl_DStringFree(&buffer); - - if (fd < 0) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ", - Tcl_PosixError(interp), (char *) NULL); - } - return NULL; - } - - sprintf(channelName, "file%d", fd); - file = Tcl_GetFile((ClientData) (intptr_t) fd, TCL_UNIX_FD); - - chan = Tcl_CreateChannel(&fileChannelType, channelName, - (channelPermissions & TCL_READABLE) ? file : NULL, - (channelPermissions & TCL_WRITABLE) ? file : NULL, - (ClientData) NULL); - - /* - * The channel may not be open now, for example if we tried to - * open a file with permissions that cannot be satisfied. - */ - - if (chan == (Tcl_Channel) NULL) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't create channel \"", - channelName, "\": ", Tcl_PosixError(interp), - (char *) NULL); - } - Tcl_FreeFile(file); - close(fd); - return NULL; - } - - if (seekFlag) { - if (Tcl_Seek(chan, 0, SEEK_END) < 0) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't seek to end of file on \"", - channelName, "\": ", Tcl_PosixError(interp), - (char *) NULL); - } - Tcl_Close(NULL, chan); - return NULL; - } - } - return chan; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_MakeFileChannel -- - * - * Makes a Tcl_Channel from an existing OS level file handle. - * - * Results: - * The Tcl_Channel created around the preexisting OS level file handle. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_MakeFileChannel( - ClientData inFd, /* OS level handle used for input. */ - ClientData outFd, /* OS level handle used for output. */ - int mode /* ORed combination of TCL_READABLE and - * TCL_WRITABLE to indicate whether inFile - * and/or outFile are valid. */ -) -{ - Tcl_File inFile, outFile; - char channelName[20]; - - if (mode == 0) { - return (Tcl_Channel) NULL; - } - - inFile = (Tcl_File) NULL; - outFile = (Tcl_File) NULL; - - if (mode & TCL_READABLE) { - sprintf(channelName, "file%d", (int) (intptr_t) inFd); - inFile = Tcl_GetFile(inFd, TCL_UNIX_FD); - } - - if (mode & TCL_WRITABLE) { - sprintf(channelName, "file%d", (int) (intptr_t) outFd); - outFile = Tcl_GetFile(outFd, TCL_UNIX_FD); - } - - return Tcl_CreateChannel(&fileChannelType, channelName, inFile, outFile, - (ClientData) NULL); -} - -/* - *---------------------------------------------------------------------- - * - * TclCreateCommandChannel -- - * - * This function is called by the generic IO level to perform - * the platform specific channel initialization for a command - * channel. - * - * Results: - * Returns a new channel or NULL on failure. - * - * Side effects: - * Allocates a new channel. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclCreateCommandChannel( - Tcl_File readFile, /* If non-null, gives the file for reading. */ - Tcl_File writeFile, /* If non-null, gives the file for writing. */ - Tcl_File errorFile, /* If non-null, gives the file where errors - * can be read. */ - int numPids, /* The number of pids in the pid array. */ - pid_t *pidPtr /* An array of process identifiers. - * Allocated by the caller, freed when - * the channel is closed or the processes - * are detached (in a background exec). */ -) -{ - Tcl_Channel channel; - char channelName[20]; - int channelId; - PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState)); - - statePtr->readFile = readFile; - statePtr->writeFile = writeFile; - statePtr->errorFile = errorFile; - statePtr->numPids = numPids; - statePtr->pidPtr = pidPtr; - - /* - * Use one of the fds associated with the channel as the - * channel id. - */ - - if (readFile) { - channelId = (int) (intptr_t) Tcl_GetFileInfo(readFile, NULL); - } else if (writeFile) { - channelId = (int) (intptr_t) Tcl_GetFileInfo(writeFile, NULL); - } else if (errorFile) { - channelId = (int) (intptr_t) Tcl_GetFileInfo(errorFile, NULL); - } else { - channelId = 0; - } - - /* - * For backward compatibility with previous versions of Tcl, we - * use "file%d" as the base name for pipes even though it would - * be more natural to use "pipe%d". - */ - - sprintf(channelName, "file%d", channelId); - channel = Tcl_CreateChannel(&pipeChannelType, channelName, readFile, - writeFile, (ClientData) statePtr); - - if (channel == NULL) { - - /* - * pidPtr will be freed by the caller if the return value is NULL. - */ - - ckfree((char *)statePtr); - } - return channel; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_PidCmd -- - * - * This procedure is invoked to process the "pid" 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_PidCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Tcl_Channel chan; /* The channel to get pids for. */ - Tcl_ChannelType *chanTypePtr; /* The type of that channel. */ - PipeState *pipePtr; /* The pipe state. */ - int i; /* Loops over PIDs attached to the - * pipe. */ - char string[50]; /* Temp buffer for string rep. of - * PIDs attached to the pipe. */ - - if (argc > 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ?channelId?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 1) { - sprintf(interp->result, "%ld", (long) getpid()); - } else { - chan = Tcl_GetChannel(interp, argv[1], NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - chanTypePtr = Tcl_GetChannelType(chan); - if (chanTypePtr != &pipeChannelType) { - return TCL_OK; - } - pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); - for (i = 0; i < pipePtr->numPids; i++) { - sprintf(string, "%ld", (long)pipePtr->pidPtr[i]); - Tcl_AppendElement(interp, string); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TcpBlockModeProc -- - * - * This procedure is invoked by the generic IO level to set blocking - * and nonblocking mode on a TCP socket based channel. - * - * Results: - * 0 if successful, errno when failed. - * - * Side effects: - * Sets the device into blocking or nonblocking mode. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TcpBlockModeProc( - ClientData instanceData, /* Socket state. */ - Tcl_File inFile, Tcl_File outFile, /* Input, output files for channel. */ - int mode /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -) -{ - TcpState *statePtr; - - statePtr = (TcpState *) instanceData; - if (mode == TCL_MODE_BLOCKING) { - statePtr->flags &= (~(TCP_ASYNC_SOCKET)); - } else { - statePtr->flags |= TCP_ASYNC_SOCKET; - } - return CommonBlockModeProc(instanceData, inFile, outFile, mode); -} - -/* - *---------------------------------------------------------------------- - * - * WaitForConnect -- - * - * Waits for a connection on an asynchronously opened socket to - * be completed. - * - * Results: - * None. - * - * Side effects: - * The socket is connected after this function returns. - * - *---------------------------------------------------------------------- - */ - -static int -WaitForConnect( - TcpState *statePtr, /* State of the socket. */ - Tcl_File fileToWaitFor, /* File to wait on to become connected. */ - int *errorCodePtr /* Where to store errors? */ -) -{ - int sock; /* The socket itself. */ - int timeOut; /* How long to wait. */ - int state; /* Of calling TclWaitForFile. */ - int flags; /* fcntl flags for the socket. */ - - /* - * If an asynchronous connect is in progress, attempt to wait for it - * to complete before reading. - */ - - if (statePtr->flags & TCP_ASYNC_CONNECT) { - if (statePtr->flags & TCP_ASYNC_SOCKET) { - timeOut = 0; - } else { - timeOut = -1; - } - errno = 0; - state = TclWaitForFile(fileToWaitFor, TCL_WRITABLE | TCL_EXCEPTION, - timeOut); - if (!(statePtr->flags & TCP_ASYNC_SOCKET)) { - sock = (int) (intptr_t) Tcl_GetFileInfo(statePtr->sock, NULL); - flags = fcntl(sock, F_GETFL); - flags &= (~(O_NONBLOCK)); - (void) fcntl(sock, F_SETFL, flags); - } - if (state & TCL_EXCEPTION) { - return -1; - } - if (state & TCL_WRITABLE) { - statePtr->flags &= (~(TCP_ASYNC_CONNECT)); - } else if (timeOut == 0) { - *errorCodePtr = errno = EWOULDBLOCK; - return -1; - } - } - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * TcpInputProc -- - * - * This procedure is invoked by the generic IO level to read input - * from a TCP socket based channel. - * - * NOTE: We cannot share code with FilePipeInputProc because here - * we must use recv to obtain the input from the channel, not read. - * - * Results: - * The number of bytes read is returned or -1 on error. An output - * argument contains the POSIX error code on error, or zero if no - * error occurred. - * - * Side effects: - * Reads input from the input device of the channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TcpInputProc( - ClientData instanceData, /* Socket state. */ - Tcl_File inFile, /* Input device for channel. */ - char *buf, /* Where to store data read. */ - int bufSize, /* How much space is available - * in the buffer? */ - int *errorCodePtr /* Where to store error code. */ -) -{ - TcpState *statePtr; /* The state of the socket. */ - int sock; /* The OS handle. */ - int bytesRead; /* How many bytes were read? */ - int state; /* Of waiting for connection. */ - - *errorCodePtr = 0; - sock = (int) (intptr_t) Tcl_GetFileInfo(inFile, NULL); - statePtr = (TcpState *) instanceData; - - state = WaitForConnect(statePtr, inFile, errorCodePtr); - if (state != 0) { - return -1; - } - bytesRead = recv(sock, buf, bufSize, 0); - if (bytesRead > -1) { - return bytesRead; - } - if (errno == ECONNRESET) { - - /* - * Turn ECONNRESET into a soft EOF condition. - */ - - return 0; - } - *errorCodePtr = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * TcpOutputProc -- - * - * This procedure is invoked by the generic IO level to write output - * to a TCP socket based channel. - * - * NOTE: We cannot share code with FilePipeOutputProc because here - * we must use send, not write, to get reliable error reporting. - * - * Results: - * The number of bytes written is returned. An output argument is - * set to a POSIX error code if an error occurred, or zero. - * - * Side effects: - * Writes output on the output device of the channel. - * - *---------------------------------------------------------------------- - */ - -static int -TcpOutputProc( - ClientData instanceData, /* Socket state. */ - Tcl_File outFile, /* Output device for channel. */ - char *buf, /* The data buffer. */ - int toWrite, /* How many bytes to write? */ - int *errorCodePtr /* Where to store error code. */ -) -{ - TcpState *statePtr; - int written; - int sock; /* OS level socket. */ - int state; /* Of waiting for connection. */ - - *errorCodePtr = 0; - sock = (int) (intptr_t) Tcl_GetFileInfo(outFile, NULL); - statePtr = (TcpState *) instanceData; - state = WaitForConnect(statePtr, outFile, errorCodePtr); - if (state != 0) { - return -1; - } - written = send(sock, buf, toWrite, 0); - if (written > -1) { - return written; - } - *errorCodePtr = errno; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * TcpCloseProc -- - * - * This procedure is invoked by the generic IO level to perform - * channel-type-specific cleanup when a TCP socket based channel - * is closed. - * - * Results: - * 0 if successful, the value of errno if failed. - * - * Side effects: - * Closes the socket of the channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TcpCloseProc( - ClientData instanceData, /* The socket to close. */ - Tcl_Interp *interp, /* For error reporting - unused. */ - Tcl_File inFile, Tcl_File outFile /* Unused. */ -) -{ - TcpState *statePtr; - Tcl_File sockFile; - int sock; - int errorCode = 0; - - statePtr = (TcpState *) instanceData; - sockFile = statePtr->sock; - sock = (int) (intptr_t) Tcl_GetFileInfo(sockFile, NULL); - - /* - * Delete a file handler that may be active for this socket if this - * is a server socket - the file handler was created automatically - * by Tcl as part of the mechanism to accept new client connections. - * Channel handlers are already deleted in the generic IO channel - * closing code that called this function, so we do not have to - * delete them here. - */ - - Tcl_DeleteFileHandler(sockFile); - - ckfree((char *) statePtr); - - /* - * We assume that inFile==outFile==sockFile and so - * we only clean up sockFile. - */ - - Tcl_FreeFile(sockFile); - - if (close(sock) < 0) { - errorCode = errno; - } - - return errorCode; -} - -/* - *---------------------------------------------------------------------- - * - * TcpGetOptionProc -- - * - * Computes an option value for a TCP socket based channel, or a - * list of all options and their values. - * - * Note: This code is based on code contributed by John Haxby. - * - * Results: - * A standard Tcl result. The value of the specified option or a - * list of all options and their values is returned in the - * supplied DString. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TcpGetOptionProc( - ClientData instanceData, /* Socket state. */ - char *optionName, /* Name of the option to - * retrieve the value for, or - * NULL to get all options and - * their values. */ - Tcl_DString *dsPtr /* Where to store the computed - * value; initialized by caller. */ -) -{ - TcpState *statePtr; - struct sockaddr_in sockname; - struct sockaddr_in peername; - struct hostent *hostEntPtr; - int sock; - int size = sizeof(struct sockaddr_in); - size_t len = 0; - char buf[128]; - - statePtr = (TcpState *) instanceData; - sock = (int) (intptr_t) Tcl_GetFileInfo(statePtr->sock, NULL); - if (optionName != (char *) NULL) { - len = strlen(optionName); - } - - if ((len == 0) || - ((len > 1) && (optionName[1] == 'p') && - (strncmp(optionName, "-peername", len) == 0))) { - if (getpeername(sock, (struct sockaddr *) &peername, &size) >= 0) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-peername"); - Tcl_DStringStartSublist(dsPtr); - } - Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); - hostEntPtr = gethostbyaddr((char *) &(peername.sin_addr), - sizeof(peername.sin_addr), AF_INET); - if (hostEntPtr != (struct hostent *) NULL) { - Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); - } else { - Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); - } - sprintf(buf, "%d", ntohs(peername.sin_port)); - Tcl_DStringAppendElement(dsPtr, buf); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; - } - } - } - - if ((len == 0) || - ((len > 1) && (optionName[1] == 's') && - (strncmp(optionName, "-sockname", len) == 0))) { - if (getsockname(sock, (struct sockaddr *) &sockname, &size) >= 0) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-sockname"); - Tcl_DStringStartSublist(dsPtr); - } - Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); - hostEntPtr = gethostbyaddr((char *) &(sockname.sin_addr), - sizeof(peername.sin_addr), AF_INET); - if (hostEntPtr != (struct hostent *) NULL) { - Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); - } else { - Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); - } - sprintf(buf, "%d", ntohs(sockname.sin_port)); - Tcl_DStringAppendElement(dsPtr, buf); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; - } - } - } - - if (len > 0) { - Tcl_SetErrno(EINVAL); - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CreateSocket -- - * - * This function opens a new socket in client or server mode - * and initializes the TcpState structure. - * - * Results: - * Returns a new TcpState, or NULL with an error in interp->result, - * if interp is not NULL. - * - * Side effects: - * Opens a socket. - * - *---------------------------------------------------------------------- - */ - -static TcpState * -CreateSocket( - Tcl_Interp *interp, /* For error reporting; can be NULL. */ - int port, /* Port number to open. */ - char *host, /* Name of host on which to open port. - * NULL implies INADDR_ANY */ - int server, /* 1 if socket should be a server socket, - * else 0 for a client socket. */ - char *myaddr, /* Optional client-side address */ - int myport, /* Optional client-side port */ - int async /* If nonzero and creating a client socket, - * attempt to do an async connect. Otherwise - * do a synchronous connect or bind. */ -) -{ - int status, sock, asyncConnect, curState, origState; - struct sockaddr_in sockaddr; /* socket address */ - struct sockaddr_in mysockaddr; /* Socket address for client */ - TcpState *statePtr; - - sock = -1; - origState = 0; - if (! CreateSocketAddress(&sockaddr, host, port)) { - goto addressError; - } - if ((myaddr != NULL || myport != 0) && - ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { - goto addressError; - } - - sock = socket(AF_INET, SOCK_STREAM, 0); - if (sock < 0) { - goto addressError; - } - - /* - * Set kernel space buffering - */ - - TclSockMinimumBuffers(sock, SOCKET_BUFSIZE); - - asyncConnect = 0; - status = 0; - if (server) { - - /* - * Set up to reuse server addresses automatically and bind to the - * specified port. - */ - - status = 1; - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status, - sizeof(status)); - status = bind(sock, (struct sockaddr *) &sockaddr, - sizeof(struct sockaddr)); - if (status != -1) { - status = listen(sock, 5); - } - } else { - if (myaddr != NULL || myport != 0) { - status = 1; - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status, - sizeof(status)); - status = bind(sock, (struct sockaddr *) &mysockaddr, - sizeof(struct sockaddr)); - if (status < 0) { - goto bindError; - } - } - - /* - * Attempt to connect. The connect may fail at present with an - * EINPROGRESS but at a later time it will complete. The caller - * will set up a file handler on the socket if she is interested in - * being informed when the connect completes. - */ - - if (async) { - origState = fcntl(sock, F_GETFL); - curState = origState | O_NONBLOCK; - status = fcntl(sock, F_SETFL, curState); - } else { - status = 0; - } - if (status > -1) { - status = connect(sock, (struct sockaddr *) &sockaddr, - sizeof(sockaddr)); - if (status < 0) { - if (errno == EINPROGRESS) { - asyncConnect = 1; - status = 0; - } - } - } - } - -bindError: - if (status < 0) { - if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", - Tcl_PosixError(interp), (char *) NULL); - } - if (sock != -1) { - close(sock); - } - return NULL; - } - - /* - * Allocate a new TcpState for this socket. - */ - - statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); - statePtr->flags = 0; - if (asyncConnect) { - statePtr->flags = TCP_ASYNC_CONNECT; - } - statePtr->sock = Tcl_GetFile((ClientData) (intptr_t) sock, TCL_UNIX_FD); - - return statePtr; - -addressError: - if (sock != -1) { - close(sock); - } - if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", - Tcl_PosixError(interp), (char *) NULL); - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * CreateSocketAddress -- - * - * This function initializes a sockaddr structure for a host and port. - * - * Results: - * 1 if the host was valid, 0 if the host could not be converted to - * an IP address. - * - * Side effects: - * Fills in the *sockaddrPtr structure. - * - *---------------------------------------------------------------------- - */ - -static int -CreateSocketAddress( - struct sockaddr_in *sockaddrPtr, /* Socket address */ - char *host, /* Host. NULL implies INADDR_ANY */ - int port /* Port number */ -) -{ - struct hostent *hostent; /* Host database entry */ - struct in_addr addr; /* For 64/32 bit madness */ - - (void) memset((VOID *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); - sockaddrPtr->sin_family = AF_INET; - sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF)); - if (host == NULL) { - addr.s_addr = INADDR_ANY; - } else { - addr.s_addr = inet_addr(host); - if (addr.s_addr == (unsigned long) -1) { - hostent = gethostbyname(host); - if (hostent != NULL) { - memcpy((VOID *) &addr, - (VOID *) hostent->h_addr_list[0], - (size_t) hostent->h_length); - } else { -#ifdef EHOSTUNREACH - errno = EHOSTUNREACH; -#else -#ifdef ENXIO - errno = ENXIO; -#endif -#endif - return 0; /* error */ - } - } - } - - /* - * NOTE: On 64 bit machines the assignment below is rumored to not - * do the right thing. Please report errors related to this if you - * observe incorrect behavior on 64 bit machines such as DEC Alphas. - * Should we modify this code to do an explicit memcpy? - */ - - sockaddrPtr->sin_addr.s_addr = addr.s_addr; - return 1; /* Success. */ -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenTcpClient -- - * - * Opens a TCP client socket and creates a channel around it. - * - * Results: - * The channel or NULL if failed. An error message is returned - * in the interpreter on failure. - * - * Side effects: - * Opens a client socket and creates a new channel. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_OpenTcpClient( - Tcl_Interp *interp, /* For error reporting; can be NULL. */ - int port, /* Port number to open. */ - char *host, /* Host on which to open port. */ - char *myaddr, /* Client-side address */ - int myport, /* Client-side port */ - int async /* If nonzero, attempt to do an - * asynchronous connect. Otherwise - * we do a blocking connect. */ -) -{ - Tcl_Channel chan; - TcpState *statePtr; - char channelName[20]; - - /* - * Create a new client socket and wrap it in a channel. - */ - - statePtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); - if (statePtr == NULL) { - return NULL; - } - - statePtr->acceptProc = NULL; - statePtr->acceptProcData = (ClientData) NULL; - - sprintf(channelName, "sock%d", - (int) (intptr_t) Tcl_GetFileInfo(statePtr->sock, NULL)); - - chan = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr->sock, - statePtr->sock, (ClientData) statePtr); - if (Tcl_SetChannelOption(interp, chan, "-translation", "auto crlf") == - TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, chan); - return NULL; - } - return chan; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_MakeTcpClientChannel -- - * - * Creates a Tcl_Channel from an existing client TCP socket. - * - * Results: - * The Tcl_Channel wrapped around the preexisting TCP socket. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_MakeTcpClientChannel( - ClientData sock /* The socket to wrap up into a channel. */ -) -{ - TcpState *statePtr; - Tcl_File sockFile; - char channelName[20]; - Tcl_Channel chan; - - sockFile = Tcl_GetFile(sock, TCL_UNIX_FD); - statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); - statePtr->sock = sockFile; - statePtr->acceptProc = NULL; - statePtr->acceptProcData = (ClientData) NULL; - - sprintf(channelName, "sock%d", (int) (intptr_t) sock); - - chan = Tcl_CreateChannel(&tcpChannelType, channelName, sockFile, sockFile, - (ClientData) statePtr); - if (Tcl_SetChannelOption((Tcl_Interp *) NULL, chan, "-translation", - "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, chan); - return NULL; - } - return chan; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenTcpServer -- - * - * Opens a TCP server socket and creates a channel around it. - * - * Results: - * The channel or NULL if failed. If an error occurred, an - * error message is left in interp->result if interp is - * not NULL. - * - * Side effects: - * Opens a server socket and creates a new channel. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_OpenTcpServer( - Tcl_Interp *interp, /* For error reporting - may be - * NULL. */ - int port, /* Port number to open. */ - char *myHost, /* Name of local host. */ - Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections - * from new clients. */ - ClientData acceptProcData /* Data for the callback. */ -) -{ - Tcl_Channel chan; - TcpState *statePtr; - char channelName[20]; - - /* - * Create a new client socket and wrap it in a channel. - */ - - statePtr = CreateSocket(interp, port, myHost, 1, NULL, 0, 0); - if (statePtr == NULL) { - return NULL; - } - - statePtr->acceptProc = acceptProc; - statePtr->acceptProcData = acceptProcData; - - /* - * Set up the callback mechanism for accepting connections - * from new clients. - */ - - Tcl_CreateFileHandler(statePtr->sock, TCL_READABLE, TcpAccept, - (ClientData) statePtr); - sprintf(channelName, "sock%d", - (int) (intptr_t) Tcl_GetFileInfo(statePtr->sock, NULL)); - chan = Tcl_CreateChannel(&tcpChannelType, channelName, NULL, NULL, - (ClientData) statePtr); - return chan; -} - -/* - *---------------------------------------------------------------------- - * - * TcpAccept -- - * Accept a TCP socket connection. This is called by the event loop. - * - * Results: - * None. - * - * Side effects: - * Creates a new connection socket. Calls the registered callback - * for the connection acceptance mechanism. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -TcpAccept( - ClientData data, /* Callback token. */ - int mask /* Not used. */ -) -{ - TcpState *sockState; /* Client data of server socket. */ - int newsock; /* The new client socket */ - Tcl_File newFile; /* Its file. */ - TcpState *newSockState; /* State for new socket. */ - struct sockaddr_in addr; /* The remote address */ - int len; /* For accept interface */ - Tcl_Channel chan; /* Channel instance created. */ - char channelName[20]; - - sockState = (TcpState *) data; - - len = sizeof(struct sockaddr_in); - newsock = accept((int) (intptr_t) Tcl_GetFileInfo(sockState->sock, NULL), - (struct sockaddr *)&addr, &len); - if (newsock < 0) { - return; - } - - newFile = Tcl_GetFile((ClientData) (intptr_t) newsock, TCL_UNIX_FD); - if (newFile) { - newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); - - newSockState->flags = 0; - newSockState->sock = newFile; - newSockState->acceptProc = (Tcl_TcpAcceptProc *) NULL; - newSockState->acceptProcData = (ClientData) NULL; - - sprintf(channelName, "sock%d", (int) newsock); - chan = Tcl_CreateChannel(&tcpChannelType, channelName, newFile, - newFile, (ClientData) newSockState); - if (chan == (Tcl_Channel) NULL) { - ckfree((char *) newSockState); - close(newsock); - Tcl_FreeFile(newFile); - } else { - if (Tcl_SetChannelOption((Tcl_Interp *) NULL, chan, "-translation", - "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, chan); - } - if (sockState->acceptProc != (Tcl_TcpAcceptProc *) NULL) { - (sockState->acceptProc) (sockState->acceptProcData, chan, - inet_ntoa(addr.sin_addr), ntohs(addr.sin_port)); - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclGetDefaultStdChannel -- - * - * Creates channels for standard input, standard output or standard - * error output if they do not already exist. - * - * Results: - * Returns the specified default standard channel, or NULL. - * - * Side effects: - * May cause the creation of a standard channel and the underlying - * file. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclGetDefaultStdChannel( - int type /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ -) -{ - Tcl_Channel channel = NULL; - int fd = 0; /* Initializations needed to prevent */ - int mode = 0; /* compiler warning (used before set). */ - char *bufMode = NULL; - - /* - * If the channels were not created yet, create them now and - * store them in the static variables. - */ - - switch (type) { - case TCL_STDIN: - fd = 0; - mode = TCL_READABLE; - bufMode = "line"; - break; - case TCL_STDOUT: - fd = 1; - mode = TCL_WRITABLE; - bufMode = "line"; - break; - case TCL_STDERR: - fd = 2; - mode = TCL_WRITABLE; - bufMode = "none"; - break; - default: - panic("TclGetDefaultStdChannel: Unexpected channel type"); - break; - } - - channel = Tcl_MakeFileChannel((ClientData) (intptr_t) fd, (ClientData) (intptr_t) fd, mode); - - /* - * Set up the normal channel options for stdio handles. - */ - - if (Tcl_SetChannelOption(NULL, channel, "-translation", "auto") == - TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, channel); - return NULL; - } - if (Tcl_SetChannelOption(NULL, channel, "-buffering", bufMode) == - TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, channel); - return NULL; - } - return channel; -} - -/* - *---------------------------------------------------------------------- - * - * TclClosePipeFile -- - * - * This function is a simple wrapper for close on a file or - * pipe handle. Called in the generic command pipeline cleanup - * code to do platform specific closing of the files associated - * with the command channel. - * - * Results: - * None. - * - * Side effects: - * Closes the fd and frees the Tcl_File. - * - *---------------------------------------------------------------------- - */ - -void -TclClosePipeFile( - Tcl_File file -) -{ - int fd = (int) (intptr_t) Tcl_GetFileInfo(file, NULL); - close(fd); - Tcl_FreeFile(file); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetOpenFile -- - * - * Given a name of a channel registered in the given interpreter, - * returns a FILE * for it. - * - * Results: - * A standard Tcl result. If the channel is registered in the given - * interpreter and it is managed by the "file" channel driver, and - * it is open for the requested mode, then the output parameter - * filePtr is set to a FILE * for the underlying file. On error, the - * filePtr is not set, TCL_ERROR is returned and an error message is - * left in interp->result. - * - * Side effects: - * May invoke fdopen to create the FILE * for the requested file. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetOpenFile( - Tcl_Interp *interp, /* Interpreter in which to find file. */ - char *string, /* String that identifies file. */ - int forWriting, /* 1 means the file is going to be used - * for writing, 0 means for reading. */ - int checkUsage, /* 1 means verify that the file was opened - * in a mode that allows the access specified - * by "forWriting". Ignored, we always - * check that the channel is open for the - * requested mode. */ - ClientData *filePtr /* Store pointer to FILE structure here. */ -) -{ - Tcl_Channel chan; - int chanMode; - Tcl_ChannelType *chanTypePtr; - Tcl_File tf; - int fd; - FILE *f; - - chan = Tcl_GetChannel(interp, string, &chanMode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) { - Tcl_AppendResult(interp, - "\"", string, "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; - } else if ((!(forWriting)) && ((chanMode & TCL_READABLE) == 0)) { - Tcl_AppendResult(interp, - "\"", string, "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; - } - - /* - * We allow creating a FILE * out of file based, pipe based and socket - * based channels. We currently do not allow any other channel types, - * because it is likely that stdio will not know what to do with them. - */ - - chanTypePtr = Tcl_GetChannelType(chan); - if ((chanTypePtr == &fileChannelType) || (chanTypePtr == &pipeChannelType) - || (chanTypePtr == &tcpChannelType)) { - tf = Tcl_GetChannelFile(chan, - (forWriting ? TCL_WRITABLE : TCL_READABLE)); - fd = (int) (intptr_t) Tcl_GetFileInfo(tf, NULL); - - /* - * The call to fdopen below is probably dangerous, since it will - * truncate an existing file if the file is being opened - * for writing.... - */ - - f = fdopen(fd, (forWriting ? "w" : "r")); - if (f == NULL) { - Tcl_AppendResult(interp, "cannot get a FILE * for \"", string, - "\"", (char *) NULL); - return TCL_ERROR; - } - *filePtr = (ClientData) f; - return TCL_OK; - } - - Tcl_AppendResult(interp, "\"", string, - "\" cannot be used to get a FILE * - unsupported type", - (char *) NULL); - return TCL_ERROR; -} diff --git a/cde/programs/dtdocbook/tcl/tclUnixFile.c b/cde/programs/dtdocbook/tcl/tclUnixFile.c deleted file mode 100644 index 37f8e4d8..00000000 --- a/cde/programs/dtdocbook/tcl/tclUnixFile.c +++ /dev/null @@ -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; -} diff --git a/cde/programs/dtdocbook/tcl/tclUnixInit.c b/cde/programs/dtdocbook/tcl/tclUnixInit.c deleted file mode 100644 index f32b0560..00000000 --- a/cde/programs/dtdocbook/tcl/tclUnixInit.c +++ /dev/null @@ -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 -#endif -#if defined(__FreeBSD__) -#include -#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); -} diff --git a/cde/programs/dtdocbook/tcl/tclUnixNotfy.c b/cde/programs/dtdocbook/tcl/tclUnixNotfy.c deleted file mode 100644 index d587c573..00000000 --- a/cde/programs/dtdocbook/tcl/tclUnixNotfy.c +++ /dev/null @@ -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 -#include - -/* - * 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); - } -} - diff --git a/cde/programs/dtdocbook/tcl/tclUnixPipe.c b/cde/programs/dtdocbook/tcl/tclUnixPipe.c deleted file mode 100644 index f8fd9344..00000000 --- a/cde/programs/dtdocbook/tcl/tclUnixPipe.c +++ /dev/null @@ -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; -} diff --git a/cde/programs/dtdocbook/tcl/tclUnixPort.h b/cde/programs/dtdocbook/tcl/tclUnixPort.h deleted file mode 100644 index 9405a9af..00000000 --- a/cde/programs/dtdocbook/tcl/tclUnixPort.h +++ /dev/null @@ -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 -#include -#ifdef HAVE_NET_ERRNO_H -# include -#endif -#include -#include -#include -#include -#ifdef USE_DIRENT2_H -# include "../compat/dirent2.h" -#else -# ifdef NO_DIRENT_H -# include "../compat/dirent.h" -# else -# include -# endif -#endif -#include -#ifdef HAVE_SYS_SELECT_H -# include -#endif -#include -#if TIME_WITH_SYS_TIME -# include -# include -#else -# if HAVE_SYS_TIME_H -# include -# else -# include -# endif -#endif -#ifndef NO_SYS_WAIT_H -# include -#endif -#ifdef HAVE_UNISTD_H -# include -#else -# include "../compat/unistd.h" -#endif - -/* - * Socket support stuff: This likely needs more work to parameterize for - * each system. - */ - -#include /* struct sockaddr, SOCK_STREAM, ... */ -#include /* uname system call. */ -#include /* struct in_addr, struct sockaddr_in */ -#include /* inet_ntoa() */ -#include /* 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 -# include -# 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 */ diff --git a/cde/programs/dtdocbook/tcl/tclUnixSock.c b/cde/programs/dtdocbook/tcl/tclUnixSock.c deleted file mode 100644 index 606f1ca8..00000000 --- a/cde/programs/dtdocbook/tcl/tclUnixSock.c +++ /dev/null @@ -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; -} diff --git a/cde/programs/dtdocbook/tcl/tclUnixTime.c b/cde/programs/dtdocbook/tcl/tclUnixTime.c deleted file mode 100644 index 76665d9d..00000000 --- a/cde/programs/dtdocbook/tcl/tclUnixTime.c +++ /dev/null @@ -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 -#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(¤tTime); - 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; -} diff --git a/cde/programs/dtdocbook/tcl/tclUtil.c b/cde/programs/dtdocbook/tcl/tclUtil.c deleted file mode 100644 index 8b1401ae..00000000 --- a/cde/programs/dtdocbook/tcl/tclUtil.c +++ /dev/null @@ -1,2186 +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: tclUtil.c /main/5 1996/08/08 14:47:12 cde-hp $ */ -/* - * tclUtil.c -- - * - * This file contains utility procedures that are used by many Tcl - * 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: @(#) tclUtil.c 1.112 96/02/15 11:42:52 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * The following values are used in the flags returned by Tcl_ScanElement - * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also - * defined in tcl.h; make sure its value doesn't overlap with any of the - * values below. - * - * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in - * braces (e.g. it contains unmatched braces, - * or ends in a backslash character, or user - * just doesn't want braces); handle all - * special characters by adding backslashes. - * USE_BRACES - 1 means the string contains a special - * character that can be handled simply by - * enclosing the entire argument in braces. - * BRACES_UNMATCHED - 1 means that braces aren't properly matched - * in the argument. - */ - -#define USE_BRACES 2 -#define BRACES_UNMATCHED 4 - -/* - * Function prototypes for local procedures in this file: - */ - -static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, - int newSpace)); - -/* - *---------------------------------------------------------------------- - * - * TclFindElement -- - * - * Given a pointer into a Tcl list, locate the first (or next) - * element in the list. - * - * Results: - * The return value is normally TCL_OK, which means that the - * element was successfully located. If TCL_ERROR is returned - * it means that list didn't have proper list structure; - * interp->result contains a more detailed error message. - * - * If TCL_OK is returned, then *elementPtr will be set to point - * to the first element of list, and *nextPtr will be set to point - * to the character just after any white space following the last - * character that's part of the element. If this is the last argument - * in the list, then *nextPtr will point to the NULL character at the - * end of list. If sizePtr is non-NULL, *sizePtr is filled in with - * the number of characters in the element. If the element is in - * braces, then *elementPtr will point to the character after the - * opening brace and *sizePtr will not include either of the braces. - * If there isn't an element in the list, *sizePtr will be zero, and - * both *elementPtr and *termPtr will refer to the null character at - * the end of list. Note: this procedure does NOT collapse backslash - * sequences. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclFindElement( - Tcl_Interp *interp, /* Interpreter to use for error reporting. - * If NULL, then no error message is left - * after errors. */ - char *list, /* String containing Tcl list with zero - * or more elements (possibly in braces). */ - char **elementPtr, /* Fill in with location of first significant - * character in first element of list. */ - char **nextPtr, /* Fill in with location of character just - * after all white space following end of - * argument (i.e. next argument or end of - * list). */ - int *sizePtr, /* If non-zero, fill in with size of - * element. */ - int *bracePtr /* If non-zero fill in with non-zero/zero - * to indicate that arg was/wasn't - * in braces. */ -) -{ - char *p; - int openBraces = 0; - int inQuotes = 0; - int size; - - /* - * Skim off leading white space and check for an opening brace or - * quote. Note: use of "isascii" below and elsewhere in this - * procedure is a temporary hack (7/27/90) because Mx uses characters - * with the high-order bit set for some things. This should probably - * be changed back eventually, or all of Tcl should call isascii. - */ - - while (isspace(UCHAR(*list))) { - list++; - } - if (*list == '{') { - openBraces = 1; - list++; - } else if (*list == '"') { - inQuotes = 1; - list++; - } - if (bracePtr != 0) { - *bracePtr = openBraces; - } - p = list; - - /* - * Find the end of the element (either a space or a close brace or - * the end of the string). - */ - - while (1) { - switch (*p) { - - /* - * Open brace: don't treat specially unless the element is - * in braces. In this case, keep a nesting count. - */ - - case '{': - if (openBraces != 0) { - openBraces++; - } - break; - - /* - * Close brace: if element is in braces, keep nesting - * count and quit when the last close brace is seen. - */ - - case '}': - if (openBraces == 1) { - char *p2; - - size = p - list; - p++; - if (isspace(UCHAR(*p)) || (*p == 0)) { - goto done; - } - for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) - && (p2 < p+20); p2++) { - /* null body */ - } - if (interp != NULL) { - Tcl_ResetResult(interp); - sprintf(interp->result, - "list element in braces followed by \"%.*s\" instead of space", - (int) (p2-p), p); - } - return TCL_ERROR; - } else if (openBraces != 0) { - openBraces--; - } - break; - - /* - * Backslash: skip over everything up to the end of the - * backslash sequence. - */ - - case '\\': { - int size; - - (void) Tcl_Backslash(p, &size); - p += size - 1; - break; - } - - /* - * Space: ignore if element is in braces or quotes; otherwise - * terminate element. - */ - - case ' ': - case '\f': - case '\n': - case '\r': - case '\t': - case '\v': - if ((openBraces == 0) && !inQuotes) { - size = p - list; - goto done; - } - break; - - /* - * Double-quote: if element is in quotes then terminate it. - */ - - case '"': - if (inQuotes) { - char *p2; - - size = p-list; - p++; - if (isspace(UCHAR(*p)) || (*p == 0)) { - goto done; - } - for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) - && (p2 < p+20); p2++) { - /* null body */ - } - if (interp != NULL) { - Tcl_ResetResult(interp); - sprintf(interp->result, - "list element in quotes followed by \"%.*s\" %s", (int) (p2-p), p, - "instead of space"); - } - return TCL_ERROR; - } - break; - - /* - * End of list: terminate element. - */ - - case 0: - if (openBraces != 0) { - if (interp != NULL) { - Tcl_SetResult(interp, "unmatched open brace in list", - TCL_STATIC); - } - return TCL_ERROR; - } else if (inQuotes) { - if (interp != NULL) { - Tcl_SetResult(interp, "unmatched open quote in list", - TCL_STATIC); - } - return TCL_ERROR; - } - size = p - list; - goto done; - - } - p++; - } - - done: - while (isspace(UCHAR(*p))) { - p++; - } - *elementPtr = list; - *nextPtr = p; - if (sizePtr != 0) { - *sizePtr = size; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCopyAndCollapse -- - * - * Copy a string and eliminate any backslashes that aren't in braces. - * - * Results: - * There is no return value. Count chars. get copied from src - * to dst. Along the way, if backslash sequences are found outside - * braces, the backslashes are eliminated in the copy. - * After scanning count chars. from source, a null character is - * placed at the end of dst. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclCopyAndCollapse( - int count, /* Total number of characters to copy - * from src. */ - char *src, /* Copy from here... */ - char *dst /* ... to here. */ -) -{ - char c; - int numRead; - - for (c = *src; count > 0; src++, c = *src, count--) { - if (c == '\\') { - *dst = Tcl_Backslash(src, &numRead); - dst++; - src += numRead-1; - count -= numRead-1; - } else { - *dst = c; - dst++; - } - } - *dst = 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SplitList -- - * - * Splits a list up into its constituent fields. - * - * Results - * The return value is normally TCL_OK, which means that - * the list was successfully split up. If TCL_ERROR is - * returned, it means that "list" didn't have proper list - * structure; interp->result will contain a more detailed - * error message. - * - * *argvPtr will be filled in with the address of an array - * whose elements point to the elements of list, in order. - * *argcPtr will get filled in with the number of valid elements - * in the array. A single block of memory is dynamically allocated - * to hold both the argv array and a copy of the list (with - * backslashes and braces removed in the standard way). - * The caller must eventually free this memory by calling free() - * on *argvPtr. Note: *argvPtr and *argcPtr are only modified - * if the procedure returns normally. - * - * Side effects: - * Memory is allocated. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SplitList( - Tcl_Interp *interp, /* Interpreter to use for error reporting. - * If NULL, then no error message is left. */ - char *list, /* Pointer to string with list structure. */ - int *argcPtr, /* Pointer to location to fill in with - * the number of elements in the list. */ - char ***argvPtr /* Pointer to place to store pointer to array - * of pointers to list elements. */ -) -{ - char **argv; - char *p; - int size, i, result, elSize, brace; - char *element; - - /* - * Figure out how much space to allocate. There must be enough - * space for both the array of pointers and also for a copy of - * the list. To estimate the number of pointers needed, count - * the number of space characters in the list. - */ - - for (size = 1, p = list; *p != 0; p++) { - if (isspace(UCHAR(*p))) { - size++; - } - } - size++; /* Leave space for final NULL pointer. */ - argv = (char **) ckalloc((unsigned) - ((size * sizeof(char *)) + (p - list) + 1)); - for (i = 0, p = ((char *) argv) + size*sizeof(char *); - *list != 0; i++) { - result = TclFindElement(interp, list, &element, &list, &elSize, &brace); - if (result != TCL_OK) { - ckfree((char *) argv); - return result; - } - if (*element == 0) { - break; - } - if (i >= size) { - ckfree((char *) argv); - if (interp != NULL) { - Tcl_SetResult(interp, "internal error in Tcl_SplitList", - TCL_STATIC); - } - return TCL_ERROR; - } - argv[i] = p; - if (brace) { - strncpy(p, element, (size_t) elSize); - p += elSize; - *p = 0; - p++; - } else { - TclCopyAndCollapse(elSize, element, p); - p += elSize+1; - } - } - - argv[i] = NULL; - *argvPtr = argv; - *argcPtr = i; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ScanElement -- - * - * This procedure is a companion procedure to Tcl_ConvertElement. - * It scans a string to see what needs to be done to it (e.g. - * add backslashes or enclosing braces) to make the string into - * a valid Tcl list element. - * - * Results: - * The return value is an overestimate of the number of characters - * that will be needed by Tcl_ConvertElement to produce a valid - * list element from string. The word at *flagPtr is filled in - * with a value needed by Tcl_ConvertElement when doing the actual - * conversion. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ScanElement( - char *string, /* String to convert to Tcl list element. */ - int *flagPtr /* Where to store information to guide - * Tcl_ConvertElement. */ -) -{ - int flags, nestingLevel; - char *p; - - /* - * This procedure and Tcl_ConvertElement together do two things: - * - * 1. They produce a proper list, one that will yield back the - * argument strings when evaluated or when disassembled with - * Tcl_SplitList. This is the most important thing. - * - * 2. They try to produce legible output, which means minimizing the - * use of backslashes (using braces instead). However, there are - * some situations where backslashes must be used (e.g. an element - * like "{abc": the leading brace will have to be backslashed. For - * each element, one of three things must be done: - * - * (a) Use the element as-is (it doesn't contain anything special - * characters). This is the most desirable option. - * - * (b) Enclose the element in braces, but leave the contents alone. - * This happens if the element contains embedded space, or if it - * contains characters with special interpretation ($, [, ;, or \), - * or if it starts with a brace or double-quote, or if there are - * no characters in the element. - * - * (c) Don't enclose the element in braces, but add backslashes to - * prevent special interpretation of special characters. This is a - * last resort used when the argument would normally fall under case - * (b) but contains unmatched braces. It also occurs if the last - * character of the argument is a backslash or if the element contains - * a backslash followed by newline. - * - * The procedure figures out how many bytes will be needed to store - * the result (actually, it overestimates). It also collects information - * about the element in the form of a flags word. - */ - - nestingLevel = 0; - flags = 0; - if (string == NULL) { - string = ""; - } - p = string; - if ((*p == '{') || (*p == '"') || (*p == 0)) { - flags |= USE_BRACES; - } - for ( ; *p != 0; p++) { - switch (*p) { - case '{': - nestingLevel++; - break; - case '}': - nestingLevel--; - if (nestingLevel < 0) { - flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; - } - break; - case '[': - case '$': - case ';': - case ' ': - case '\f': - case '\n': - case '\r': - case '\t': - case '\v': - flags |= USE_BRACES; - break; - case '\\': - if ((p[1] == 0) || (p[1] == '\n')) { - flags = TCL_DONT_USE_BRACES; - } else { - int size; - - (void) Tcl_Backslash(p, &size); - p += size-1; - flags |= USE_BRACES; - } - break; - } - } - if (nestingLevel != 0) { - flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; - } - *flagPtr = flags; - - /* - * Allow enough space to backslash every character plus leave - * two spaces for braces. - */ - - return 2*(p-string) + 2; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ConvertElement -- - * - * This is a companion procedure to Tcl_ScanElement. Given the - * information produced by Tcl_ScanElement, this procedure converts - * a string to a list element equal to that string. - * - * Results: - * Information is copied to *dst in the form of a list element - * identical to src (i.e. if Tcl_SplitList is applied to dst it - * will produce a string identical to src). The return value is - * a count of the number of characters copied (not including the - * terminating NULL character). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ConvertElement( - char *src, /* Source information for list element. */ - char *dst, /* Place to put list-ified element. */ - int flags /* Flags produced by Tcl_ScanElement. */ -) -{ - char *p = dst; - - /* - * See the comment block at the beginning of the Tcl_ScanElement - * code for details of how this works. - */ - - if ((src == NULL) || (*src == 0)) { - p[0] = '{'; - p[1] = '}'; - p[2] = 0; - return 2; - } - if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { - *p = '{'; - p++; - for ( ; *src != 0; src++, p++) { - *p = *src; - } - *p = '}'; - p++; - } else { - if (*src == '{') { - /* - * Can't have a leading brace unless the whole element is - * enclosed in braces. Add a backslash before the brace. - * Furthermore, this may destroy the balance between open - * and close braces, so set BRACES_UNMATCHED. - */ - - p[0] = '\\'; - p[1] = '{'; - p += 2; - src++; - flags |= BRACES_UNMATCHED; - } - for (; *src != 0 ; src++) { - switch (*src) { - case ']': - case '[': - case '$': - case ';': - case ' ': - case '\\': - case '"': - *p = '\\'; - p++; - break; - case '{': - case '}': - /* - * It may not seem necessary to backslash braces, but - * it is. The reason for this is that the resulting - * list element may actually be an element of a sub-list - * enclosed in braces (e.g. if Tcl_DStringStartSublist - * has been invoked), so there may be a brace mismatch - * if the braces aren't backslashed. - */ - - if (flags & BRACES_UNMATCHED) { - *p = '\\'; - p++; - } - break; - case '\f': - *p = '\\'; - p++; - *p = 'f'; - p++; - continue; - case '\n': - *p = '\\'; - p++; - *p = 'n'; - p++; - continue; - case '\r': - *p = '\\'; - p++; - *p = 'r'; - p++; - continue; - case '\t': - *p = '\\'; - p++; - *p = 't'; - p++; - continue; - case '\v': - *p = '\\'; - p++; - *p = 'v'; - p++; - continue; - } - *p = *src; - p++; - } - } - *p = '\0'; - return p-dst; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Merge -- - * - * Given a collection of strings, merge them together into a - * single string that has proper Tcl list structured (i.e. - * Tcl_SplitList may be used to retrieve strings equal to the - * original elements, and Tcl_Eval will parse the string back - * into its original elements). - * - * Results: - * The return value is the address of a dynamically-allocated - * string containing the merged list. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_Merge( - int argc, /* How many strings to merge. */ - char **argv /* Array of string values. */ -) -{ -# define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr; - int numChars; - char *result; - char *dst; - int i; - - /* - * Pass 1: estimate space, gather flags. - */ - - if (argc <= LOCAL_SIZE) { - flagPtr = localFlags; - } else { - flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); - } - numChars = 1; - for (i = 0; i < argc; i++) { - numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; - } - - /* - * Pass two: copy into the result area. - */ - - result = (char *) ckalloc((unsigned) numChars); - dst = result; - for (i = 0; i < argc; i++) { - numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); - dst += numChars; - *dst = ' '; - dst++; - } - if (dst == result) { - *dst = 0; - } else { - dst[-1] = 0; - } - - if (flagPtr != localFlags) { - ckfree((char *) flagPtr); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Concat -- - * - * Concatenate a set of strings into a single large string. - * - * Results: - * The return value is dynamically-allocated string containing - * a concatenation of all the strings in argv, with spaces between - * the original argv elements. - * - * Side effects: - * Memory is allocated for the result; the caller is responsible - * for freeing the memory. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_Concat( - int argc, /* Number of strings to concatenate. */ - char **argv /* Array of strings to concatenate. */ -) -{ - int totalSize, i; - char *p; - char *result; - - for (totalSize = 1, i = 0; i < argc; i++) { - totalSize += strlen(argv[i]) + 1; - } - result = (char *) ckalloc((unsigned) totalSize); - if (argc == 0) { - *result = '\0'; - return result; - } - for (p = result, i = 0; i < argc; i++) { - char *element; - int length; - - /* - * Clip white space off the front and back of the string - * to generate a neater result, and ignore any empty - * elements. - */ - - element = argv[i]; - while (isspace(UCHAR(*element))) { - element++; - } - for (length = strlen(element); - (length > 0) && (isspace(UCHAR(element[length-1]))); - length--) { - /* Null loop body. */ - } - if (length == 0) { - continue; - } - (void) strncpy(p, element, (size_t) length); - p += length; - *p = ' '; - p++; - } - if (p != result) { - p[-1] = 0; - } else { - *p = 0; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_StringMatch -- - * - * See if a particular string matches a particular pattern. - * - * Results: - * The return value is 1 if string matches pattern, and - * 0 otherwise. The matching operation permits the following - * special characters in the pattern: *?\[] (see the manual - * entry for details on what these mean). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_StringMatch( - char *string, /* String. */ - char *pattern /* Pattern, which may contain something */ -) -{ - char c2; - - while (1) { - /* See if we're at the end of both the pattern and the string. - * If so, we succeeded. If we're at the end of the pattern - * but not at the end of the string, we failed. - */ - - if (*pattern == 0) { - if (*string == 0) { - return 1; - } else { - return 0; - } - } - if ((*string == 0) && (*pattern != '*')) { - return 0; - } - - /* Check for a "*" as the next pattern character. It matches - * any substring. We handle this by calling ourselves - * recursively for each postfix of string, until either we - * match or we reach the end of the string. - */ - - if (*pattern == '*') { - pattern += 1; - if (*pattern == 0) { - return 1; - } - while (1) { - if (Tcl_StringMatch(string, pattern)) { - return 1; - } - if (*string == 0) { - return 0; - } - string += 1; - } - } - - /* Check for a "?" as the next pattern character. It matches - * any single character. - */ - - if (*pattern == '?') { - goto thisCharOK; - } - - /* Check for a "[" as the next pattern character. It is followed - * by a list of characters that are acceptable, or by a range - * (two characters separated by "-"). - */ - - if (*pattern == '[') { - pattern += 1; - while (1) { - if ((*pattern == ']') || (*pattern == 0)) { - return 0; - } - if (*pattern == *string) { - break; - } - if (pattern[1] == '-') { - c2 = pattern[2]; - if (c2 == 0) { - return 0; - } - if ((*pattern <= *string) && (c2 >= *string)) { - break; - } - if ((*pattern >= *string) && (c2 <= *string)) { - break; - } - pattern += 2; - } - pattern += 1; - } - while (*pattern != ']') { - if (*pattern == 0) { - pattern--; - break; - } - pattern += 1; - } - goto thisCharOK; - } - - /* If the next pattern character is '/', just strip off the '/' - * so we do exact matching on the character that follows. - */ - - if (*pattern == '\\') { - pattern += 1; - if (*pattern == 0) { - return 0; - } - } - - /* There's no special character. Just make sure that the next - * characters of each string match. - */ - - if (*pattern != *string) { - return 0; - } - - thisCharOK: pattern += 1; - string += 1; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetResult -- - * - * Arrange for "string" to be the Tcl return value. - * - * Results: - * None. - * - * Side effects: - * interp->result is left pointing either to "string" (if "copy" is 0) - * or to a copy of string. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetResult( - Tcl_Interp *interp, /* Interpreter with which to associate the - * return value. */ - char *string, /* Value to be returned. If NULL, - * the result is set to an empty string. */ - Tcl_FreeProc *freeProc /* Gives information about the string: - * TCL_STATIC, TCL_VOLATILE, or the address - * of a Tcl_FreeProc such as free. */ -) -{ - Interp *iPtr = (Interp *) interp; - int length; - Tcl_FreeProc *oldFreeProc = iPtr->freeProc; - char *oldResult = iPtr->result; - - if (string == NULL) { - iPtr->resultSpace[0] = 0; - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } else if (freeProc == TCL_DYNAMIC) { - iPtr->result = string; - iPtr->freeProc = TCL_DYNAMIC; - } else if (freeProc == TCL_VOLATILE) { - length = strlen(string); - if (length > TCL_RESULT_SIZE) { - iPtr->result = (char *) ckalloc((unsigned) length+1); - iPtr->freeProc = TCL_DYNAMIC; - } else { - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } - strcpy(iPtr->result, string); - } else { - iPtr->result = string; - iPtr->freeProc = freeProc; - } - - /* - * If the old result was dynamically-allocated, free it up. Do it - * here, rather than at the beginning, in case the new result value - * was part of the old result value. - */ - - if (oldFreeProc != 0) { - if ((oldFreeProc == TCL_DYNAMIC) - || (oldFreeProc == (Tcl_FreeProc *) free)) { - ckfree(oldResult); - } else { - (*oldFreeProc)(oldResult); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendResult -- - * - * Append a variable number of strings onto the result already - * present for an interpreter. - * - * Results: - * None. - * - * Side effects: - * The result in the interpreter given by the first argument - * is extended by the strings given by the second and following - * arguments (up to a terminating NULL argument). - * - *---------------------------------------------------------------------- - */ - - /* VARARGS2 */ -void -Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) -{ - va_list argList; - Interp *iPtr; - char *string; - int newSpace; - - /* - * First, scan through all the arguments to see how much space is - * needed. - */ - - iPtr = (Interp *)arg1; - va_start(argList, arg1); - newSpace = 0; - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - newSpace += strlen(string); - } - va_end(argList); - - /* - * If the append buffer isn't already setup and large enough - * to hold the new data, set it up. - */ - - if ((iPtr->result != iPtr->appendResult) - || (iPtr->appendResult[iPtr->appendUsed] != 0) - || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { - SetupAppendBuffer(iPtr, newSpace); - } - - /* - * Final step: go through all the argument strings again, copying - * them into the buffer. - */ - - va_start(argList, arg1); - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - strcpy(iPtr->appendResult + iPtr->appendUsed, string); - iPtr->appendUsed += strlen(string); - } - va_end(argList); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendElement -- - * - * Convert a string to a valid Tcl list element and append it - * to the current result (which is ostensibly a list). - * - * Results: - * None. - * - * Side effects: - * The result in the interpreter given by the first argument - * is extended with a list element converted from string. A - * separator space is added before the converted list element - * unless the current result is empty, contains the single - * character "{", or ends in " {". - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendElement( - Tcl_Interp *interp, /* Interpreter whose result is to be - * extended. */ - char *string /* String to convert to list element and - * add to result. */ -) -{ - Interp *iPtr = (Interp *) interp; - int size, flags; - char *dst; - - /* - * See how much space is needed, and grow the append buffer if - * needed to accommodate the list element. - */ - - size = Tcl_ScanElement(string, &flags) + 1; - if ((iPtr->result != iPtr->appendResult) - || (iPtr->appendResult[iPtr->appendUsed] != 0) - || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { - SetupAppendBuffer(iPtr, size+iPtr->appendUsed); - } - - /* - * Convert the string into a list element and copy it to the - * buffer that's forming, with a space separator if needed. - */ - - dst = iPtr->appendResult + iPtr->appendUsed; - if (TclNeedSpace(iPtr->appendResult, dst)) { - iPtr->appendUsed++; - *dst = ' '; - dst++; - } - iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); -} - -/* - *---------------------------------------------------------------------- - * - * SetupAppendBuffer -- - * - * This procedure makes sure that there is an append buffer - * properly initialized for interp, and that it has at least - * enough room to accommodate newSpace new bytes of information. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -SetupAppendBuffer( - Interp *iPtr, /* Interpreter whose result is being set up. */ - int newSpace /* Make sure that at least this many bytes - * of new information may be added. */ -) -{ - int totalSpace; - - /* - * Make the append buffer larger, if that's necessary, then - * copy the current result into the append buffer and make the - * append buffer the official Tcl result. - */ - - if (iPtr->result != iPtr->appendResult) { - /* - * If an oversized buffer was used recently, then free it up - * so we go back to a smaller buffer. This avoids tying up - * memory forever after a large operation. - */ - - if (iPtr->appendAvl > 500) { - ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - } - iPtr->appendUsed = strlen(iPtr->result); - } else if (iPtr->result[iPtr->appendUsed] != 0) { - /* - * Most likely someone has modified a result created by - * Tcl_AppendResult et al. so that it has a different size. - * Just recompute the size. - */ - - iPtr->appendUsed = strlen(iPtr->result); - } - totalSpace = newSpace + iPtr->appendUsed; - if (totalSpace >= iPtr->appendAvl) { - char *new; - - if (totalSpace < 100) { - totalSpace = 200; - } else { - totalSpace *= 2; - } - new = (char *) ckalloc((unsigned) totalSpace); - strcpy(new, iPtr->result); - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - } - iPtr->appendResult = new; - iPtr->appendAvl = totalSpace; - } else if (iPtr->result != iPtr->appendResult) { - strcpy(iPtr->appendResult, iPtr->result); - } - Tcl_FreeResult(iPtr); - iPtr->result = iPtr->appendResult; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ResetResult -- - * - * This procedure restores the result area for an interpreter - * to its default initialized state, freeing up any memory that - * may have been allocated for the result and clearing any - * error information for the interpreter. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_ResetResult( - Tcl_Interp *interp /* Interpreter for which to clear result. */ -) -{ - Interp *iPtr = (Interp *) interp; - - Tcl_FreeResult(iPtr); - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; - iPtr->flags &= - ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetErrorCode -- - * - * This procedure is called to record machine-readable information - * about an error that is about to be returned. - * - * Results: - * None. - * - * Side effects: - * The errorCode global variable is modified to hold all of the - * arguments to this procedure, in a list form with each argument - * becoming one element of the list. A flag is set internally - * to remember that errorCode has been set, so the variable doesn't - * get set automatically when the error is returned. - * - *---------------------------------------------------------------------- - */ - /* VARARGS2 */ -void -Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) -{ - va_list argList; - char *string; - int flags; - Interp *iPtr; - - /* - * Scan through the arguments one at a time, appending them to - * $errorCode as list elements. - */ - - iPtr = (Interp *)arg1; - va_start(argList, arg1); - flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", - (char *) NULL, string, flags); - flags |= TCL_APPEND_VALUE; - } - va_end(argList); - iPtr->flags |= ERROR_CODE_SET; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetListIndex -- - * - * Parse a list index, which may be either an integer or the - * value "end". - * - * Results: - * The return value is either TCL_OK or TCL_ERROR. If it is - * TCL_OK, then the index corresponding to string is left in - * *indexPtr. If the return value is TCL_ERROR, then string - * was bogus; an error message is returned in interp->result. - * If a negative index is specified, it is rounded up to 0. - * The index value may be larger than the size of the list - * (this happens when "end" is specified). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGetListIndex( - Tcl_Interp *interp, /* Interpreter for error reporting. */ - char *string, /* String containing list index. */ - int *indexPtr /* Where to store index. */ -) -{ - if (isdigit(UCHAR(*string)) || (*string == '-')) { - if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { - return TCL_ERROR; - } - if (*indexPtr < 0) { - *indexPtr = 0; - } - } else if (strncmp(string, "end", strlen(string)) == 0) { - *indexPtr = INT_MAX; - } else { - Tcl_AppendResult(interp, "bad index \"", string, - "\": must be integer or \"end\"", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RegExpCompile -- - * - * Compile a regular expression into a form suitable for fast - * matching. This procedure retains a small cache of pre-compiled - * regular expressions in the interpreter, in order to avoid - * compilation costs as much as possible. - * - * Results: - * The return value is a pointer to the compiled form of string, - * suitable for passing to Tcl_RegExpExec. This compiled form - * is only valid up until the next call to this procedure, so - * don't keep these around for a long time! If an error occurred - * while compiling the pattern, then NULL is returned and an error - * message is left in interp->result. - * - * Side effects: - * The cache of compiled regexp's in interp will be modified to - * hold information for string, if such information isn't already - * present in the cache. - * - *---------------------------------------------------------------------- - */ - -Tcl_RegExp -Tcl_RegExpCompile( - Tcl_Interp *interp, /* For use in error reporting. */ - char *string /* String for which to produce - * compiled regular expression. */ -) -{ - Interp *iPtr = (Interp *) interp; - int i, length; - regexp *result; - - length = strlen(string); - for (i = 0; i < NUM_REGEXPS; i++) { - if ((length == iPtr->patLengths[i]) - && (strcmp(string, iPtr->patterns[i]) == 0)) { - /* - * Move the matched pattern to the first slot in the - * cache and shift the other patterns down one position. - */ - - if (i != 0) { - int j; - char *cachedString; - - cachedString = iPtr->patterns[i]; - result = iPtr->regexps[i]; - for (j = i-1; j >= 0; j--) { - iPtr->patterns[j+1] = iPtr->patterns[j]; - iPtr->patLengths[j+1] = iPtr->patLengths[j]; - iPtr->regexps[j+1] = iPtr->regexps[j]; - } - iPtr->patterns[0] = cachedString; - iPtr->patLengths[0] = length; - iPtr->regexps[0] = result; - } - return (Tcl_RegExp) iPtr->regexps[0]; - } - } - - /* - * No match in the cache. Compile the string and add it to the - * cache. - */ - - TclRegError((char *) NULL); - result = TclRegComp(string); - if (TclGetRegError() != NULL) { - Tcl_AppendResult(interp, - "couldn't compile regular expression pattern: ", - TclGetRegError(), (char *) NULL); - return NULL; - } - if (iPtr->patterns[NUM_REGEXPS-1] != NULL) { - ckfree(iPtr->patterns[NUM_REGEXPS-1]); - ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]); - } - for (i = NUM_REGEXPS - 2; i >= 0; i--) { - iPtr->patterns[i+1] = iPtr->patterns[i]; - iPtr->patLengths[i+1] = iPtr->patLengths[i]; - iPtr->regexps[i+1] = iPtr->regexps[i]; - } - iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1)); - strcpy(iPtr->patterns[0], string); - iPtr->patLengths[0] = length; - iPtr->regexps[0] = result; - return (Tcl_RegExp) result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RegExpExec -- - * - * Execute the regular expression matcher using a compiled form - * of a regular expression and save information about any match - * that is found. - * - * Results: - * If an error occurs during the matching operation then -1 - * is returned and interp->result contains an error message. - * Otherwise the return value is 1 if a matching range is - * found and 0 if there is no matching range. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_RegExpExec( - Tcl_Interp *interp, /* Interpreter to use for error reporting. */ - Tcl_RegExp re, /* Compiled regular expression; must have - * been returned by previous call to - * Tcl_RegExpCompile. */ - char *string, /* String against which to match re. */ - char *start /* If string is part of a larger string, - * this identifies beginning of larger - * string, so that "^" won't match. */ -) -{ - int match; - - regexp *regexpPtr = (regexp *) re; - TclRegError((char *) NULL); - match = TclRegExec(regexpPtr, string, start); - if (TclGetRegError() != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error while matching regular expression: ", - TclGetRegError(), (char *) NULL); - return -1; - } - return match; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RegExpRange -- - * - * Returns pointers describing the range of a regular expression match, - * or one of the subranges within the match. - * - * Results: - * The variables at *startPtr and *endPtr are modified to hold the - * addresses of the endpoints of the range given by index. If the - * specified range doesn't exist then NULLs are returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_RegExpRange( - Tcl_RegExp re, /* Compiled regular expression that has - * been passed to Tcl_RegExpExec. */ - int index, /* 0 means give the range of the entire - * match, > 0 means give the range of - * a matching subrange. Must be no greater - * than NSUBEXP. */ - char **startPtr, /* Store address of first character in - * (sub-) range here. */ - char **endPtr /* Store address of character just after last - * in (sub-) range here. */ -) -{ - regexp *regexpPtr = (regexp *) re; - - if (index >= NSUBEXP) { - *startPtr = *endPtr = NULL; - } else { - *startPtr = regexpPtr->startp[index]; - *endPtr = regexpPtr->endp[index]; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RegExpMatch -- - * - * See if a string matches a regular expression. - * - * Results: - * If an error occurs during the matching operation then -1 - * is returned and interp->result contains an error message. - * Otherwise the return value is 1 if "string" matches "pattern" - * and 0 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_RegExpMatch( - Tcl_Interp *interp, /* Used for error reporting. */ - char *string, /* String. */ - char *pattern /* Regular expression to match against - * string. */ -) -{ - Tcl_RegExp re; - - re = Tcl_RegExpCompile(interp, pattern); - if (re == NULL) { - return -1; - } - return Tcl_RegExpExec(interp, re, string, string); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DStringInit -- - * - * Initializes a dynamic string, discarding any previous contents - * of the string (Tcl_DStringFree should have been called already - * if the dynamic string was previously in use). - * - * Results: - * None. - * - * Side effects: - * The dynamic string is initialized to be empty. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DStringInit( - Tcl_DString *dsPtr /* Pointer to structure for - * dynamic string. */ -) -{ - dsPtr->string = dsPtr->staticSpace; - dsPtr->length = 0; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - dsPtr->staticSpace[0] = 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DStringAppend -- - * - * Append more characters to the current value of a dynamic string. - * - * Results: - * The return value is a pointer to the dynamic string's new value. - * - * Side effects: - * Length bytes from string (or all of string if length is less - * than zero) are added to the current value of the string. Memory - * gets reallocated if needed to accommodate the string's new size. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_DStringAppend( - Tcl_DString *dsPtr, /* Structure describing dynamic - * string. */ - char *string, /* String to append. If length is - * -1 then this must be - * null-terminated. */ - int length /* Number of characters from string - * to append. If < 0, then append all - * of string, up to null at end. */ -) -{ - int newSize; - char *newString, *dst, *end; - - if (length < 0) { - length = strlen(string); - } - newSize = length + dsPtr->length; - - /* - * Allocate a larger buffer for the string if the current one isn't - * large enough. Allocate extra space in the new buffer so that there - * will be room to grow before we have to allocate again. - */ - - if (newSize >= dsPtr->spaceAvl) { - dsPtr->spaceAvl = newSize*2; - newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); - memcpy((VOID *)newString, (VOID *) dsPtr->string, - (size_t) dsPtr->length); - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); - } - dsPtr->string = newString; - } - - /* - * Copy the new string into the buffer at the end of the old - * one. - */ - - for (dst = dsPtr->string + dsPtr->length, end = string+length; - string < end; string++, dst++) { - *dst = *string; - } - *dst = 0; - dsPtr->length += length; - return dsPtr->string; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DStringAppendElement -- - * - * Append a list element to the current value of a dynamic string. - * - * Results: - * The return value is a pointer to the dynamic string's new value. - * - * Side effects: - * String is reformatted as a list element and added to the current - * value of the string. Memory gets reallocated if needed to - * accommodate the string's new size. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_DStringAppendElement( - Tcl_DString *dsPtr, /* Structure describing dynamic - * string. */ - char *string /* String to append. Must be - * null-terminated. */ -) -{ - int newSize, flags; - char *dst, *newString; - - newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; - - /* - * Allocate a larger buffer for the string if the current one isn't - * large enough. Allocate extra space in the new buffer so that there - * will be room to grow before we have to allocate again. - * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string - * to a larger buffer, since there may be embedded NULLs in the - * string in some cases. - */ - - if (newSize >= dsPtr->spaceAvl) { - dsPtr->spaceAvl = newSize*2; - newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); - memcpy((VOID *) newString, (VOID *) dsPtr->string, - (size_t) dsPtr->length); - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); - } - dsPtr->string = newString; - } - - /* - * Convert the new string to a list element and copy it into the - * buffer at the end, with a space, if needed. - */ - - dst = dsPtr->string + dsPtr->length; - if (TclNeedSpace(dsPtr->string, dst)) { - *dst = ' '; - dst++; - dsPtr->length++; - } - dsPtr->length += Tcl_ConvertElement(string, dst, flags); - return dsPtr->string; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DStringSetLength -- - * - * Change the length of a dynamic string. This can cause the - * string to either grow or shrink, depending on the value of - * length. - * - * Results: - * None. - * - * Side effects: - * The length of dsPtr is changed to length and a null byte is - * stored at that position in the string. If length is larger - * than the space allocated for dsPtr, then a panic occurs. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DStringSetLength( - Tcl_DString *dsPtr, /* Structure describing dynamic - * string. */ - int length /* New length for dynamic string. */ -) -{ - if (length < 0) { - length = 0; - } - if (length >= dsPtr->spaceAvl) { - char *newString; - - dsPtr->spaceAvl = length+1; - newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); - - /* - * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string - * to a larger buffer, since there may be embedded NULLs in the - * string in some cases. - */ - - memcpy((VOID *) newString, (VOID *) dsPtr->string, - (size_t) dsPtr->length); - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); - } - dsPtr->string = newString; - } - dsPtr->length = length; - dsPtr->string[length] = 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DStringFree -- - * - * Frees up any memory allocated for the dynamic string and - * reinitializes the string to an empty state. - * - * Results: - * None. - * - * Side effects: - * The previous contents of the dynamic string are lost, and - * the new value is an empty string. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DStringFree( - Tcl_DString *dsPtr /* Structure describing dynamic - * string. */ -) -{ - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); - } - dsPtr->string = dsPtr->staticSpace; - dsPtr->length = 0; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - dsPtr->staticSpace[0] = 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DStringResult -- - * - * This procedure moves the value of a dynamic string into an - * interpreter as its result. The string itself is reinitialized - * to an empty string. - * - * Results: - * None. - * - * Side effects: - * The string is "moved" to interp's result, and any existing - * result for interp is freed up. DsPtr is reinitialized to - * an empty string. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DStringResult( - Tcl_Interp *interp, /* Interpreter whose result is to be - * reset. */ - Tcl_DString *dsPtr /* Dynamic string that is to become - * the result of interp. */ -) -{ - Tcl_ResetResult(interp); - if (dsPtr->string != dsPtr->staticSpace) { - interp->result = dsPtr->string; - interp->freeProc = TCL_DYNAMIC; - } else if (dsPtr->length < TCL_RESULT_SIZE) { - interp->result = ((Interp *) interp)->resultSpace; - strcpy(interp->result, dsPtr->string); - } else { - Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); - } - dsPtr->string = dsPtr->staticSpace; - dsPtr->length = 0; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - dsPtr->staticSpace[0] = 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DStringGetResult -- - * - * This procedure moves the result of an interpreter into a - * dynamic string. - * - * Results: - * None. - * - * Side effects: - * The interpreter's result is cleared, and the previous contents - * of dsPtr are freed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DStringGetResult( - Tcl_Interp *interp, /* Interpreter whose result is to be - * reset. */ - Tcl_DString *dsPtr /* Dynamic string that is to become - * the result of interp. */ -) -{ - Interp *iPtr = (Interp *) interp; - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); - } - dsPtr->length = strlen(iPtr->result); - if (iPtr->freeProc != NULL) { - if ((iPtr->freeProc == TCL_DYNAMIC) - || (iPtr->freeProc == (Tcl_FreeProc *) free)) { - dsPtr->string = iPtr->result; - dsPtr->spaceAvl = dsPtr->length+1; - } else { - dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); - strcpy(dsPtr->string, iPtr->result); - (*iPtr->freeProc)(iPtr->result); - } - dsPtr->spaceAvl = dsPtr->length+1; - iPtr->freeProc = NULL; - } else { - if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { - dsPtr->string = dsPtr->staticSpace; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - } else { - dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); - dsPtr->spaceAvl = dsPtr->length + 1; - } - strcpy(dsPtr->string, iPtr->result); - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DStringStartSublist -- - * - * This procedure adds the necessary information to a dynamic - * string (e.g. " {" to start a sublist. Future element - * appends will be in the sublist rather than the main list. - * - * Results: - * None. - * - * Side effects: - * Characters get added to the dynamic string. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DStringStartSublist( - Tcl_DString *dsPtr /* Dynamic string. */ -) -{ - if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { - Tcl_DStringAppend(dsPtr, " {", -1); - } else { - Tcl_DStringAppend(dsPtr, "{", -1); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DStringEndSublist -- - * - * This procedure adds the necessary characters to a dynamic - * string to end a sublist (e.g. "}"). Future element appends - * will be in the enclosing (sub)list rather than the current - * sublist. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DStringEndSublist( - Tcl_DString *dsPtr /* Dynamic string. */ -) -{ - Tcl_DStringAppend(dsPtr, "}", -1); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_PrintDouble -- - * - * Given a floating-point value, this procedure converts it to - * an ASCII string using. - * - * Results: - * The ASCII equivalent of "value" is written at "dst". It is - * written using the current precision, and it is guaranteed to - * contain a decimal point or exponent, so that it looks like - * a floating-point value and not an integer. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_PrintDouble( - Tcl_Interp *interp, /* Interpreter whose tcl_precision - * variable controls printing. */ - double value, /* Value to print as string. */ - char *dst /* Where to store converted value; - * must have at least TCL_DOUBLE_SPACE - * characters. */ -) -{ - char *p; - sprintf(dst, ((Interp *) interp)->pdFormat, value); - - /* - * If the ASCII result looks like an integer, add ".0" so that it - * doesn't look like an integer anymore. This prevents floating-point - * values from being converted to integers unintentionally. - */ - - for (p = dst; *p != 0; p++) { - if ((*p == '.') || (isalpha(UCHAR(*p)))) { - return; - } - } - p[0] = '.'; - p[1] = '0'; - p[2] = 0; -} - -/* - *---------------------------------------------------------------------- - * - * TclPrecTraceProc -- - * - * This procedure is invoked whenever the variable "tcl_precision" - * is written. - * - * Results: - * Returns NULL if all went well, or an error message if the - * new value for the variable doesn't make sense. - * - * Side effects: - * If the new value doesn't make sense then this procedure - * undoes the effect of the variable modification. Otherwise - * it modifies the format string that's used by Tcl_PrintDouble. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -char * -TclPrecTraceProc( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Interpreter containing variable. */ - char *name1, /* Name of variable. */ - char *name2, /* Second part of variable name. */ - int flags /* Information about what happened. */ -) -{ - Interp *iPtr = (Interp *) interp; - char *value, *end; - int prec; - - /* - * If the variable is unset, then recreate the trace and restore - * the default value of the format string. - */ - - if (flags & TCL_TRACE_UNSETS) { - if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_TraceVar2(interp, name1, name2, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - TclPrecTraceProc, clientData); - } - strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); - iPtr->pdPrec = DEFAULT_PD_PREC; - return (char *) NULL; - } - - value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); - if (value == NULL) { - value = ""; - } - prec = strtoul(value, &end, 10); - if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || - (end == value) || (*end != 0)) { - char oldValue[10]; - - sprintf(oldValue, "%d", iPtr->pdPrec); - Tcl_SetVar2(interp, name1, name2, oldValue, flags & TCL_GLOBAL_ONLY); - return "improper value for precision"; - } - sprintf(iPtr->pdFormat, "%%.%dg", prec); - iPtr->pdPrec = prec; - return (char *) NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclNeedSpace -- - * - * This procedure checks to see whether it is appropriate to - * add a space before appending a new list element to an - * existing string. - * - * Results: - * The return value is 1 if a space is appropriate, 0 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclNeedSpace( - char *start, /* First character in string. */ - char *end /* End of string (place where space will - * be added, if appropriate). */ -) -{ - /* - * A space is needed unless either - * (a) we're at the start of the string, or - * (b) the trailing characters of the string consist of one or more - * open curly braces preceded by a space or extending back to - * the beginning of the string. - * (c) the trailing characters of the string consist of a space - * preceded by a character other than backslash. - */ - - if (end == start) { - return 0; - } - end--; - if (*end != '{') { - if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) { - return 0; - } - return 1; - } - do { - if (end == start) { - return 0; - } - end--; - } while (*end == '{'); - if (isspace(UCHAR(*end))) { - return 0; - } - return 1; -} diff --git a/cde/programs/dtdocbook/tcl/tclVar.c b/cde/programs/dtdocbook/tcl/tclVar.c deleted file mode 100644 index eb2e3d5c..00000000 --- a/cde/programs/dtdocbook/tcl/tclVar.c +++ /dev/null @@ -1,2628 +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: tclVar.c /main/3 1996/10/03 16:42:27 drk $ */ -/* - * tclVar.c -- - * - * This file contains routines that implement Tcl variables - * (both scalars and arrays). - * - * The implementation of arrays is modelled after an initial - * implementation by Mark Diekhans and Karl Lehenbauer. - * - * Copyright (c) 1987-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: @(#) tclVar.c 1.69 96/02/28 21:45:10 - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * The strings below are used to indicate what went wrong when a - * variable access is denied. - */ - -static char *noSuchVar = "no such variable"; -static char *isArray = "variable is array"; -static char *needArray = "variable isn't array"; -static char *noSuchElement = "no such element in array"; -static char *danglingUpvar = "upvar refers to element in deleted array"; - -/* - * Creation flag values passed in to LookupVar: - * - * CRT_PART1 - 1 means create hash table entry for part 1 of - * name, if it doesn't already exist. 0 means - * return an error if it doesn't exist. - * CRT_PART2 - 1 means create hash table entry for part 2 of - * name, if it doesn't already exist. 0 means - * return an error if it doesn't exist. - */ - -#define CRT_PART1 1 -#define CRT_PART2 2 - -/* - * The following additional flag is used internally and passed through - * to LookupVar to indicate that a procedure like Tcl_GetVar was called - * instead of Tcl_GetVar2 and the single name value hasn't yet been - * parsed into an array name and index (if any). - */ - -#define PART1_NOT_PARSED 0x10000 - -/* - * Forward references to procedures defined later in this file: - */ - -static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, - Var *varPtr, char *part1, char *part2, - int flags)); -static void CleanupVar _ANSI_ARGS_((Var *varPtr, Var *arrayPtr)); -static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr)); -static void DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName, - Var *varPtr, int flags)); -static Var * LookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1, - char *part2, int flags, char *msg, int create, - Var **arrayPtrPtr)); -static int MakeUpvar _ANSI_ARGS_((Interp *iPtr, - CallFrame *framePtr, char *otherP1, - char *otherP2, char *myName, int flags)); -static Var * NewVar _ANSI_ARGS_((void)); -static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, - Var *varPtr, char *varName, char *string)); -static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, char *operation, - char *reason)); - -/* - *---------------------------------------------------------------------- - * - * LookupVar -- - * - * This procedure is used by virtually all of the variable - * code to locate a variable given its name(s). - * - * Results: - * The return value is a pointer to the variable indicated by - * part1 and part2, or NULL if the variable couldn't be found. - * If the variable is found, *arrayPtrPtr is filled in with - * the address of the array that contains the variable (or NULL - * if the variable is a scalar). Note: it's possible that the - * variable returned may be VAR_UNDEFINED, even if CRT_PART1 and - * CRT_PART2 are specified (these only cause the hash table entry - * and/or array to be created). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static Var * -LookupVar( - Tcl_Interp *interp, /* Interpreter to use for lookup. */ - char *part1, /* If part2 isn't NULL, this is the name - * of an array. Otherwise, if the - * PART1_NOT_PARSED flag bit is set this - * is a full variable name that could - * include a parenthesized array elemnt. - * If PART1_NOT_PARSED isn't present, then - * this is the name of a scalar variable. */ - char *part2, /* Name of an element within array, or NULL. */ - int flags, /* Only the TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG, - * and PART1_NOT_PARSED bits matter. */ - char *msg, /* Verb to use in error messages, e.g. - * "read" or "set". Only needed if - * TCL_LEAVE_ERR_MSG is set in flags. */ - int create, /* OR'ed combination of CRT_PART1 and - * CRT_PART2. Tells which entries to create - * if they don't already exist. */ - Var **arrayPtrPtr /* If the name refers to an element of an - * array, *arrayPtrPtr gets filled in with - * address of array variable. Otherwise - * this is set to NULL. */ -) -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; - Var *varPtr; - int new; - char *openParen, *closeParen; /* If this procedure parses a name - * into array and index, these point - * to the parens around the index. - * Otherwise they are NULL. These - * are needed to restore the parens - * after parsing the name. */ - char *elName; /* Name of array element or NULL; - * may be same as part2, or may be - * openParen+1. */ - char *p; - - /* - * If the name hasn't been parsed into array name and index yet, - * do it now. - */ - - openParen = closeParen = NULL; - elName = part2; - if (flags & PART1_NOT_PARSED) { - for (p = part1; ; p++) { - if (*p == 0) { - elName = NULL; - break; - } - if (*p == '(') { - openParen = p; - do { - p++; - } while (*p != '\0'); - p--; - if (*p == ')') { - closeParen = p; - *openParen = 0; - elName = openParen+1; - } else { - openParen = NULL; - elName = NULL; - } - break; - } - } - } - - /* - * Lookup part1. - */ - - *arrayPtrPtr = NULL; - if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) { - tablePtr = &iPtr->globalTable; - } else { - tablePtr = &iPtr->varFramePtr->varTable; - } - if (create & CRT_PART1) { - hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new); - if (openParen != NULL) { - *openParen = '('; - } - if (new) { - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - } - } else { - hPtr = Tcl_FindHashEntry(tablePtr, part1); - if (openParen != NULL) { - *openParen = '('; - } - if (hPtr == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchVar); - } - return NULL; - } - } - varPtr = (Var *) Tcl_GetHashValue(hPtr); - if (varPtr->flags & VAR_UPVAR) { - varPtr = varPtr->value.upvarPtr; - } - - if (elName == NULL) { - return varPtr; - } - - /* - * We're dealing with an array element, so make sure the variable - * is an array and lookup the element (create it if desired). - */ - - if (varPtr->flags & VAR_UNDEFINED) { - if (!(create & CRT_PART1)) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchVar); - } - return NULL; - } - varPtr->flags = VAR_ARRAY; - varPtr->value.tablePtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); - } else if (!(varPtr->flags & VAR_ARRAY)) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, needArray); - } - return NULL; - } - *arrayPtrPtr = varPtr; - if (closeParen != NULL) { - *closeParen = 0; - } - if (create & CRT_PART2) { - hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new); - if (closeParen != NULL) { - *closeParen = ')'; - } - if (new) { - if (varPtr->searchPtr != NULL) { - DeleteSearches(varPtr); - } - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - } - } else { - hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName); - if (closeParen != NULL) { - *closeParen = ')'; - } - if (hPtr == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchElement); - } - return NULL; - } - } - return (Var *) Tcl_GetHashValue(hPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetVar -- - * - * Return the value of a Tcl variable. - * - * Results: - * The return value points to the current value of varName. If - * the variable is not defined or can't be read because of a clash - * in array usage then a NULL pointer is returned and an error - * message is left in interp->result if the TCL_LEAVE_ERR_MSG - * flag is set. Note: the return value is only valid up until - * the next call to Tcl_SetVar or Tcl_SetVar2; if you depend on - * the value lasting longer than that, then make yourself a private - * copy. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_GetVar( - Tcl_Interp *interp, /* Command interpreter in which varName is - * to be looked up. */ - char *varName, /* Name of a variable in interp. */ - int flags /* OR-ed combination of TCL_GLOBAL_ONLY - * or TCL_LEAVE_ERR_MSG bits. */ -) -{ - return Tcl_GetVar2(interp, varName, (char *) NULL, - flags | PART1_NOT_PARSED); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetVar2 -- - * - * Return the value of a Tcl variable, given a two-part name - * consisting of array name and element within array. - * - * Results: - * The return value points to the current value of the variable - * given by part1 and part2. If the specified variable doesn't - * exist, or if there is a clash in array usage, then NULL is - * returned and a message will be left in interp->result if the - * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is - * only valid up until the next call to Tcl_SetVar or Tcl_SetVar2; - * if you depend on the value lasting longer than that, then make - * yourself a private copy. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_GetVar2( - Tcl_Interp *interp, /* Command interpreter in which variable is - * to be looked up. */ - char *part1, /* Name of array (if part2 is NULL) or - * name of variable. */ - char *part2, /* If non-null, gives name of element in - * array. */ - int flags /* OR-ed combination of TCL_GLOBAL_ONLY, - * TCL_LEAVE_ERR_MSG, and PART1_NOT_PARSED - * bits. */ -) -{ - Var *varPtr, *arrayPtr; - Interp *iPtr = (Interp *) interp; - - varPtr = LookupVar(interp, part1, part2, flags, "read", CRT_PART2, - &arrayPtr); - if (varPtr == NULL) { - return NULL; - } - - /* - * Invoke any traces that have been set for the variable. - */ - - if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - char *msg; - - msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_READS); - if (msg != NULL) { - VarErrMsg(interp, part1, part2, "read", msg); - goto cleanup; - } - } - if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) { - return varPtr->value.string; - } - if (flags & TCL_LEAVE_ERR_MSG) { - char *msg; - - if ((varPtr->flags & VAR_UNDEFINED) && (arrayPtr != NULL) - && !(arrayPtr->flags & VAR_UNDEFINED)) { - msg = noSuchElement; - } else if (varPtr->flags & VAR_ARRAY) { - msg = isArray; - } else { - msg = noSuchVar; - } - VarErrMsg(interp, part1, part2, "read", msg); - } - - /* - * If the variable doesn't exist anymore and no-one's using it, - * then free up the relevant structures and hash table entries. - */ - - cleanup: - if (varPtr->flags & VAR_UNDEFINED) { - CleanupVar(varPtr, arrayPtr); - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetVar -- - * - * Change the value of a variable. - * - * Results: - * Returns a pointer to the malloc'ed string holding the new - * value of the variable. The caller should not modify this - * string. If the write operation was disallowed then NULL - * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then - * an explanatory message will be left in interp->result. - * - * Side effects: - * If varName is defined as a local or global variable in interp, - * its value is changed to newValue. If varName isn't currently - * defined, then a new global variable by that name is created. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_SetVar( - Tcl_Interp *interp, /* Command interpreter in which varName is - * to be looked up. */ - char *varName, /* Name of a variable in interp. */ - char *newValue, /* New value for varName. */ - int flags /* Various flags that tell how to set value: - * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */ -) -{ - return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, - flags | PART1_NOT_PARSED); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetVar2 -- - * - * Given a two-part variable name, which may refer either to a - * scalar variable or an element of an array, change the value - * of the variable. If the named scalar or array or element - * doesn't exist then create one. - * - * Results: - * Returns a pointer to the malloc'ed string holding the new - * value of the variable. The caller should not modify this - * string. If the write operation was disallowed because an - * array was expected but not found (or vice versa), then NULL - * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then - * an explanatory message will be left in interp->result. - * - * Side effects: - * The value of the given variable is set. If either the array - * or the entry didn't exist then a new one is created. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_SetVar2( - Tcl_Interp *interp, /* Command interpreter in which variable is - * to be looked up. */ - char *part1, /* If part2 is NULL, this is name of scalar - * variable. Otherwise it is name of array. */ - char *part2, /* Name of an element within array, or NULL. */ - char *newValue, /* New value for variable. */ - int flags /* Various flags that tell how to set value: - * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or - * PART1_NOT_PARSED. */ -) -{ - Var *varPtr; - Interp *iPtr = (Interp *) interp; - int length, listFlags; - Var *arrayPtr; - char *result; - - varPtr = LookupVar(interp, part1, part2, flags, "set", CRT_PART1|CRT_PART2, - &arrayPtr); - if (varPtr == NULL) { - return NULL; - } - - /* - * If the variable's hPtr field is NULL, it means that this is an - * upvar to an array element where the array was deleted, leaving - * the element dangling at the end of the upvar. Generate an error - * (allowing the variable to be reset would screw up our storage - * allocation and is meaningless anyway). - */ - - if (varPtr->hPtr == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "set", danglingUpvar); - } - return NULL; - } - - /* - * Clear the variable's current value unless this is an - * append operation. - */ - - if (varPtr->flags & VAR_ARRAY) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "set", isArray); - } - return NULL; - } - if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) { - varPtr->valueLength = 0; - } - - /* - * Call read trace if variable is being appended to. - */ - - if ((flags & TCL_APPEND_VALUE) && ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { - char *msg; - msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_READS); - if (msg != NULL) { - VarErrMsg(interp, part1, part2, "read", msg); - result = NULL; - goto cleanup; - } - } - - /* - * Compute how many total bytes will be needed for the variable's - * new value (leave space for a separating space between list - * elements). Allocate new space for the value if needed. - */ - - if (flags & TCL_LIST_ELEMENT) { - length = Tcl_ScanElement(newValue, &listFlags) + 1; - } else { - length = strlen(newValue); - } - length += varPtr->valueLength; - if (length >= varPtr->valueSpace) { - char *newValue; - int newSize; - - newSize = 2*varPtr->valueSpace; - if (newSize <= length) { - newSize = length + 1; - } - if (newSize < 24) { - /* - * Don't waste time with teensy-tiny variables; we'll - * just end up expanding them later. - */ - - newSize = 24; - } - newValue = (char *) ckalloc((unsigned) newSize); - if (varPtr->valueSpace > 0) { - strcpy(newValue, varPtr->value.string); - ckfree(varPtr->value.string); - } - varPtr->valueSpace = newSize; - varPtr->value.string = newValue; - } - - /* - * Append the new value to the variable, either as a list - * element or as a string. - */ - - if (flags & TCL_LIST_ELEMENT) { - char *dst = varPtr->value.string + varPtr->valueLength; - - if (TclNeedSpace(varPtr->value.string, dst)) { - *dst = ' '; - dst++; - varPtr->valueLength++; - } - varPtr->valueLength += Tcl_ConvertElement(newValue, dst, listFlags); - } else { - strcpy(varPtr->value.string + varPtr->valueLength, newValue); - varPtr->valueLength = length; - } - varPtr->flags &= ~VAR_UNDEFINED; - - /* - * Invoke any write traces for the variable. - */ - - if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - char *msg; - - msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) - | TCL_TRACE_WRITES); - if (msg != NULL) { - VarErrMsg(interp, part1, part2, "set", msg); - result = NULL; - goto cleanup; - } - } - - /* - * If the variable was changed in some gross way by a trace (e.g. - * it was unset and then recreated as an array) then just return - * an empty string; otherwise return the variable's current - * value. - */ - - if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) { - return varPtr->value.string; - } - result = ""; - - /* - * If the variable doesn't exist anymore and no-one's using it, - * then free up the relevant structures and hash table entries. - */ - - cleanup: - if (varPtr->flags & VAR_UNDEFINED) { - CleanupVar(varPtr, arrayPtr); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UnsetVar -- - * - * Delete a variable, so that it may not be accessed anymore. - * - * Results: - * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR - * if the variable can't be unset. In the event of an error, - * if the TCL_LEAVE_ERR_MSG flag is set then an error message - * is left in interp->result. - * - * Side effects: - * If varName is defined as a local or global variable in interp, - * it is deleted. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_UnsetVar( - Tcl_Interp *interp, /* Command interpreter in which varName is - * to be looked up. */ - char *varName, /* Name of a variable in interp. May be - * either a scalar name or an array name - * or an element in an array. */ - int flags /* OR-ed combination of any of - * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */ -) -{ - return Tcl_UnsetVar2(interp, varName, (char *) NULL, - flags | PART1_NOT_PARSED); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UnsetVar2 -- - * - * Delete a variable, given a 2-part name. - * - * Results: - * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR - * if the variable can't be unset. In the event of an error, - * if the TCL_LEAVE_ERR_MSG flag is set then an error message - * is left in interp->result. - * - * Side effects: - * If part1 and part2 indicate a local or global variable in interp, - * it is deleted. If part1 is an array name and part2 is NULL, then - * the whole array is deleted. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_UnsetVar2( - Tcl_Interp *interp, /* Command interpreter in which varName is - * to be looked up. */ - char *part1, /* Name of variable or array. */ - char *part2, /* Name of element within array or NULL. */ - int flags /* OR-ed combination of any of - * TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG, - * or PART1_NOT_PARSED. */ -) -{ - Var *varPtr, dummyVar; - Interp *iPtr = (Interp *) interp; - Var *arrayPtr; - ActiveVarTrace *activePtr; - int result; - - varPtr = LookupVar(interp, part1, part2, flags, "unset", 0, &arrayPtr); - if (varPtr == NULL) { - return TCL_ERROR; - } - result = (varPtr->flags & VAR_UNDEFINED) ? TCL_ERROR : TCL_OK; - - if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) { - DeleteSearches(arrayPtr); - } - - /* - * The code below is tricky, because of the possibility that - * a trace procedure might try to access a variable being - * deleted. To handle this situation gracefully, do things - * in three steps: - * 1. Copy the contents of the variable to a dummy variable - * structure, and mark the original structure as undefined. - * 2. Invoke traces and clean up the variable, using the copy. - * 3. If at the end of this the original variable is still - * undefined and has no outstanding references, then delete - * it (but it could have gotten recreated by a trace). - */ - - dummyVar = *varPtr; - varPtr->valueSpace = 0; - varPtr->flags = VAR_UNDEFINED; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - - /* - * Call trace procedures for the variable being deleted and delete - * its traces. Be sure to abort any other traces for the variable - * that are still pending. Special tricks: - * 1. Increment varPtr's refCount around this: CallTraces will - * use dummyVar so it won't increment varPtr's refCount. - * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to - * call unset traces even if other traces are pending. - */ - - if ((dummyVar.tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - varPtr->refCount++; - dummyVar.flags &= ~VAR_TRACE_ACTIVE; - (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, - (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) - | TCL_TRACE_UNSETS); - while (dummyVar.tracePtr != NULL) { - VarTrace *tracePtr = dummyVar.tracePtr; - dummyVar.tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); - } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { - if (activePtr->varPtr == varPtr) { - activePtr->nextTracePtr = NULL; - } - } - varPtr->refCount--; - } - - /* - * If the variable is an array, delete all of its elements. This - * must be done after calling the traces on the array, above (that's - * the way traces are defined). - */ - - if (dummyVar.flags & VAR_ARRAY) { - DeleteArray(iPtr, part1, &dummyVar, - (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS); - } - if (dummyVar.valueSpace > 0) { - ckfree(dummyVar.value.string); - } - if (result == TCL_ERROR) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "unset", - (arrayPtr == NULL) ? noSuchVar : noSuchElement); - } - } - - /* - * Finally, if the variable is truly not in use then free up its - * record and remove it from the hash table. - */ - - CleanupVar(varPtr, arrayPtr); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_TraceVar -- - * - * Arrange for reads and/or writes to a variable to cause a - * procedure to be invoked, which can monitor the operations - * and/or change their actions. - * - * Results: - * A standard Tcl return value. - * - * Side effects: - * A trace is set up on the variable given by varName, such that - * future references to the variable will be intermediated by - * proc. See the manual entry for complete details on the calling - * sequence for proc. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_TraceVar( - Tcl_Interp *interp, /* Interpreter in which variable is - * to be traced. */ - char *varName, /* Name of variable; may end with "(index)" - * to signify an array reference. */ - int flags, /* OR-ed collection of bits, including any - * of TCL_TRACE_READS, TCL_TRACE_WRITES, - * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ - Tcl_VarTraceProc *proc, /* Procedure to call when specified ops are - * invoked upon varName. */ - ClientData clientData /* Arbitrary argument to pass to proc. */ -) -{ - return Tcl_TraceVar2(interp, varName, (char *) NULL, - flags | PART1_NOT_PARSED, proc, clientData); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_TraceVar2 -- - * - * Arrange for reads and/or writes to a variable to cause a - * procedure to be invoked, which can monitor the operations - * and/or change their actions. - * - * Results: - * A standard Tcl return value. - * - * Side effects: - * A trace is set up on the variable given by part1 and part2, such - * that future references to the variable will be intermediated by - * proc. See the manual entry for complete details on the calling - * sequence for proc. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_TraceVar2( - Tcl_Interp *interp, /* Interpreter in which variable is - * to be traced. */ - char *part1, /* Name of scalar variable or array. */ - char *part2, /* Name of element within array; NULL means - * trace applies to scalar variable or array - * as-a-whole. */ - int flags, /* OR-ed collection of bits, including any - * of TCL_TRACE_READS, TCL_TRACE_WRITES, - * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and - * PART1_NOT_PARSED. */ - Tcl_VarTraceProc *proc, /* Procedure to call when specified ops are - * invoked upon varName. */ - ClientData clientData /* Arbitrary argument to pass to proc. */ -) -{ - Var *varPtr, *arrayPtr; - VarTrace *tracePtr; - - varPtr = LookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG), - "trace", CRT_PART1|CRT_PART2, &arrayPtr); - if (varPtr == NULL) { - return TCL_ERROR; - } - - /* - * Set up trace information. - */ - - tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); - tracePtr->traceProc = proc; - tracePtr->clientData = clientData; - tracePtr->flags = flags & - (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS); - tracePtr->nextPtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UntraceVar -- - * - * Remove a previously-created trace for a variable. - * - * Results: - * None. - * - * Side effects: - * If there exists a trace for the variable given by varName - * with the given flags, proc, and clientData, then that trace - * is removed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_UntraceVar( - Tcl_Interp *interp, /* Interpreter containing traced variable. */ - char *varName, /* Name of variable; may end with "(index)" - * to signify an array reference. */ - int flags, /* OR-ed collection of bits describing - * current trace, including any of - * TCL_TRACE_READS, TCL_TRACE_WRITES, - * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ - Tcl_VarTraceProc *proc, /* Procedure assocated with trace. */ - ClientData clientData /* Arbitrary argument to pass to proc. */ -) -{ - Tcl_UntraceVar2(interp, varName, (char *) NULL, flags | PART1_NOT_PARSED, - proc, clientData); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UntraceVar2 -- - * - * Remove a previously-created trace for a variable. - * - * Results: - * None. - * - * Side effects: - * If there exists a trace for the variable given by part1 - * and part2 with the given flags, proc, and clientData, then - * that trace is removed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_UntraceVar2( - Tcl_Interp *interp, /* Interpreter containing traced variable. */ - char *part1, /* Name of variable or array. */ - char *part2, /* Name of element within array; NULL means - * trace applies to scalar variable or array - * as-a-whole. */ - int flags, /* OR-ed collection of bits describing - * current trace, including any of - * TCL_TRACE_READS, TCL_TRACE_WRITES, - * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and - * PART1_NOT_PARSED. */ - Tcl_VarTraceProc *proc, /* Procedure assocated with trace. */ - ClientData clientData /* Arbitrary argument to pass to proc. */ -) -{ - VarTrace *tracePtr; - VarTrace *prevPtr; - Var *varPtr, *arrayPtr; - Interp *iPtr = (Interp *) interp; - ActiveVarTrace *activePtr; - - varPtr = LookupVar(interp, part1, part2, - flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0, - &arrayPtr); - if (varPtr == NULL) { - return; - } - - flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); - for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; - prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { - if (tracePtr == NULL) { - return; - } - if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) - && (tracePtr->clientData == clientData)) { - break; - } - } - - /* - * The code below makes it possible to delete traces while traces - * are active: it makes sure that the deleted trace won't be - * processed by CallTraces. - */ - - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { - if (activePtr->nextTracePtr == tracePtr) { - activePtr->nextTracePtr = tracePtr->nextPtr; - } - } - if (prevPtr == NULL) { - varPtr->tracePtr = tracePtr->nextPtr; - } else { - prevPtr->nextPtr = tracePtr->nextPtr; - } - ckfree((char *) tracePtr); - - /* - * If this is the last trace on the variable, and the variable is - * unset and unused, then free up the variable. - */ - - if (varPtr->flags & VAR_UNDEFINED) { - CleanupVar(varPtr, (Var *) NULL); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_VarTraceInfo -- - * - * Return the clientData value associated with a trace on a - * variable. This procedure can also be used to step through - * all of the traces on a particular variable that have the - * same trace procedure. - * - * Results: - * The return value is the clientData value associated with - * a trace on the given variable. Information will only be - * returned for a trace with proc as trace procedure. If - * the clientData argument is NULL then the first such trace is - * returned; otherwise, the next relevant one after the one - * given by clientData will be returned. If the variable - * doesn't exist, or if there are no (more) traces for it, - * then NULL is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_VarTraceInfo( - Tcl_Interp *interp, /* Interpreter containing variable. */ - char *varName, /* Name of variable; may end with "(index)" - * to signify an array reference. */ - int flags, /* 0 or TCL_GLOBAL_ONLY. */ - Tcl_VarTraceProc *proc, /* Procedure assocated with trace. */ - ClientData prevClientData /* If non-NULL, gives last value returned - * by this procedure, so this call will - * return the next trace after that one. - * If NULL, this call will return the - * first trace. */ -) -{ - return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, - flags | PART1_NOT_PARSED, proc, prevClientData); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_VarTraceInfo2 -- - * - * Same as Tcl_VarTraceInfo, except takes name in two pieces - * instead of one. - * - * Results: - * Same as Tcl_VarTraceInfo. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_VarTraceInfo2( - Tcl_Interp *interp, /* Interpreter containing variable. */ - char *part1, /* Name of variable or array. */ - char *part2, /* Name of element within array; NULL means - * trace applies to scalar variable or array - * as-a-whole. */ - int flags, /* OR-ed combination of TCL_GLOBAL_ONLY and - * PART1_NOT_PARSED. */ - Tcl_VarTraceProc *proc, /* Procedure assocated with trace. */ - ClientData prevClientData /* If non-NULL, gives last value returned - * by this procedure, so this call will - * return the next trace after that one. - * If NULL, this call will return the - * first trace. */ -) -{ - VarTrace *tracePtr; - Var *varPtr, *arrayPtr; - - varPtr = LookupVar(interp, part1, part2, - flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0, - &arrayPtr); - if (varPtr == NULL) { - return NULL; - } - - /* - * Find the relevant trace, if any, and return its clientData. - */ - - tracePtr = varPtr->tracePtr; - if (prevClientData != NULL) { - for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { - if ((tracePtr->clientData == prevClientData) - && (tracePtr->traceProc == proc)) { - tracePtr = tracePtr->nextPtr; - break; - } - } - } - for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { - if (tracePtr->traceProc == proc) { - return tracePtr->clientData; - } - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetCmd -- - * - * This procedure is invoked to process the "set" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result value. - * - * Side effects: - * A variable's value may be changed. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_SetCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - if (argc == 2) { - char *value; - - value = Tcl_GetVar2(interp, argv[1], (char *) NULL, - TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); - if (value == NULL) { - return TCL_ERROR; - } - interp->result = value; - return TCL_OK; - } else if (argc == 3) { - char *result; - - result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], - TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); - if (result == NULL) { - return TCL_ERROR; - } - interp->result = result; - return TCL_OK; - } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName ?newValue?\"", (char *) NULL); - return TCL_ERROR; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UnsetCmd -- - * - * This procedure is invoked to process the "unset" 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_UnsetCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int i; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName ?varName ...?\"", (char *) NULL); - return TCL_ERROR; - } - for (i = 1; i < argc; i++) { - if (Tcl_UnsetVar2(interp, argv[i], (char *) NULL, - TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED) != TCL_OK) { - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendCmd -- - * - * This procedure is invoked to process the "append" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result value. - * - * Side effects: - * A variable's value may be changed. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_AppendCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int i; - char *result = NULL; /* (Initialization only needed to keep - * the compiler from complaining) */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName ?value value ...?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 2) { - result = Tcl_GetVar2(interp, argv[1], (char *) NULL, - TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); - if (result == NULL) { - return TCL_ERROR; - } - interp->result = result; - return TCL_OK; - } - - for (i = 2; i < argc; i++) { - result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i], - TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); - if (result == NULL) { - return TCL_ERROR; - } - } - interp->result = result; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LappendCmd -- - * - * This procedure is invoked to process the "lappend" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result value. - * - * Side effects: - * A variable's value may be changed. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_LappendCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int i; - char *result = NULL; /* (Initialization only needed to keep - * the compiler from complaining) */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName ?value value ...?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 2) { - result = Tcl_GetVar2(interp, argv[1], (char *) NULL, - TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); - if (result == NULL) { - return TCL_ERROR; - } - interp->result = result; - return TCL_OK; - } - - for (i = 2; i < argc; i++) { - result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i], - TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG - |PART1_NOT_PARSED); - if (result == NULL) { - return TCL_ERROR; - } - } - interp->result = result; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ArrayCmd -- - * - * This procedure is invoked to process the "array" 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_ArrayCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - int c, notArray; - size_t length; - Var *varPtr = NULL; /* Initialization needed only to prevent - * compiler warning. */ - Tcl_HashEntry *hPtr; - Interp *iPtr = (Interp *) interp; - - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option arrayName ?arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * Locate the array variable (and it better be an array). - */ - - if (iPtr->varFramePtr == NULL) { - hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]); - } else { - hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]); - } - notArray = 0; - if (hPtr == NULL) { - notArray = 1; - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - if (varPtr->flags & VAR_UPVAR) { - varPtr = varPtr->value.upvarPtr; - } - if (!(varPtr->flags & VAR_ARRAY)) { - notArray = 1; - } - } - - /* - * Dispatch based on the option. - */ - - c = argv[1][0]; - length = strlen(argv[1]); - if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) { - ArraySearch *searchPtr; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " anymore arrayName searchId\"", (char *) NULL); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); - if (searchPtr == NULL) { - return TCL_ERROR; - } - while (1) { - Var *varPtr2; - - if (searchPtr->nextEntry != NULL) { - varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); - if (!(varPtr2->flags & VAR_UNDEFINED)) { - break; - } - } - searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); - if (searchPtr->nextEntry == NULL) { - interp->result = "0"; - return TCL_OK; - } - } - interp->result = "1"; - return TCL_OK; - } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) { - ArraySearch *searchPtr, *prevPtr; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " donesearch arrayName searchId\"", (char *) NULL); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); - if (searchPtr == NULL) { - return TCL_ERROR; - } - if (varPtr->searchPtr == searchPtr) { - varPtr->searchPtr = searchPtr->nextPtr; - } else { - for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) { - if (prevPtr->nextPtr == searchPtr) { - prevPtr->nextPtr = searchPtr->nextPtr; - break; - } - } - } - ckfree((char *) searchPtr); - } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " exists arrayName\"", (char *) NULL); - return TCL_ERROR; - } - interp->result = (notArray) ? "0" : "1"; - } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { - Tcl_HashSearch search; - Var *varPtr2; - char *name; - - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " get arrayName ?pattern?\"", (char *) NULL); - return TCL_ERROR; - } - if (notArray) { - return TCL_OK; - } - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (varPtr2->flags & VAR_UNDEFINED) { - continue; - } - name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) { - continue; - } - Tcl_AppendElement(interp, name); - Tcl_AppendElement(interp, varPtr2->value.string); - } - } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0) - && (length >= 2)) { - Tcl_HashSearch search; - Var *varPtr2; - char *name; - - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " names arrayName ?pattern?\"", (char *) NULL); - return TCL_ERROR; - } - if (notArray) { - return TCL_OK; - } - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (varPtr2->flags & VAR_UNDEFINED) { - continue; - } - name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) { - continue; - } - Tcl_AppendElement(interp, name); - } - } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0) - && (length >= 2)) { - ArraySearch *searchPtr; - Tcl_HashEntry *hPtr; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " nextelement arrayName searchId\"", - (char *) NULL); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); - if (searchPtr == NULL) { - return TCL_ERROR; - } - while (1) { - Var *varPtr2; - - hPtr = searchPtr->nextEntry; - if (hPtr == NULL) { - hPtr = Tcl_NextHashEntry(&searchPtr->search); - if (hPtr == NULL) { - return TCL_OK; - } - } else { - searchPtr->nextEntry = NULL; - } - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (!(varPtr2->flags & VAR_UNDEFINED)) { - break; - } - } - interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0) - && (length >= 2)) { - char **valueArgv; - int valueArgc, i, result; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " set arrayName list\"", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_SplitList(interp, argv[3], &valueArgc, &valueArgv) != TCL_OK) { - return TCL_ERROR; - } - result = TCL_OK; - if (valueArgc & 1) { - interp->result = "list must have an even number of elements"; - result = TCL_ERROR; - goto setDone; - } - for (i = 0; i < valueArgc; i += 2) { - if (Tcl_SetVar2(interp, argv[2], valueArgv[i], valueArgv[i+1], - TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - break; - } - } - setDone: - ckfree((char *) valueArgv); - return result; - } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) - && (length >= 2)) { - Tcl_HashSearch search; - Var *varPtr2; - int size; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " size arrayName\"", (char *) NULL); - return TCL_ERROR; - } - size = 0; - if (!notArray) { - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (varPtr2->flags & VAR_UNDEFINED) { - continue; - } - size++; - } - } - sprintf(interp->result, "%ld", (long)size); - } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0) - && (length >= 2)) { - ArraySearch *searchPtr; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " startsearch arrayName\"", (char *) NULL); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); - if (varPtr->searchPtr == NULL) { - searchPtr->id = 1; - Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL); - } else { - char string[20]; - - searchPtr->id = varPtr->searchPtr->id + 1; - sprintf(string, "%d", searchPtr->id); - Tcl_AppendResult(interp, "s-", string, "-", argv[2], - (char *) NULL); - } - searchPtr->varPtr = varPtr; - searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, - &searchPtr->search); - searchPtr->nextPtr = varPtr->searchPtr; - varPtr->searchPtr = searchPtr; - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be anymore, donesearch, exists, ", - "get, names, nextelement, ", - "set, size, or startsearch", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; - - error: - Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array", - (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * MakeUpvar -- - * - * This procedure does all of the work of the "global" and "upvar" - * commands. - * - * Results: - * A standard Tcl completion code. If an error occurs then an - * error message is left in iPtr->result. - * - * Side effects: - * The variable given by myName is linked to the variable in - * framePtr given by otherP1 and otherP2, so that references to - * myName are redirected to the other variable like a symbolic -* link. - * - *---------------------------------------------------------------------- - */ - -static int -MakeUpvar( - Interp *iPtr, /* Interpreter containing variables. Used - * for error messages, too. */ - CallFrame *framePtr, /* Call frame containing "other" variable. - * NULL means use global context. */ - char *otherP1, char *otherP2,/* Two-part name of variable in framePtr. */ - char *myName, /* Name of variable in local table, which - * will refer to otherP1/P2. Must be a - * scalar. */ - int flags /* 0 or TCL_GLOBAL_ONLY: indicates scope of - * myName. */ -) -{ - Tcl_HashEntry *hPtr; - Var *otherPtr, *varPtr, *arrayPtr; - CallFrame *savedFramePtr; - int new; - - /* - * In order to use LookupVar to find "other", temporarily replace - * the current frame pointer in the interpreter. - */ - - savedFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = framePtr; - otherPtr = LookupVar((Tcl_Interp *) iPtr, otherP1, otherP2, - TCL_LEAVE_ERR_MSG, "access", CRT_PART1|CRT_PART2, &arrayPtr); - iPtr->varFramePtr = savedFramePtr; - if (otherPtr == NULL) { - return TCL_ERROR; - } - if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) { - hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, myName, &new); - } else { - hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, myName, &new); - } - if (new) { - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - } else { - /* - * The variable already exists. Make sure that this variable - * isn't also "otherVar" (avoid circular links). Also, if it's - * not an upvar then it's an error. If it is an upvar, then - * just disconnect it from the thing it currently refers to. - */ - - varPtr = (Var *) Tcl_GetHashValue(hPtr); - if (varPtr == otherPtr) { - iPtr->result = "can't upvar from variable to itself"; - return TCL_ERROR; - } - if (varPtr->flags & VAR_UPVAR) { - Var *upvarPtr; - - upvarPtr = varPtr->value.upvarPtr; - if (upvarPtr == otherPtr) { - return TCL_OK; - } - upvarPtr->refCount--; - if (upvarPtr->flags & VAR_UNDEFINED) { - CleanupVar(upvarPtr, (Var *) NULL); - } - } else if (!(varPtr->flags & VAR_UNDEFINED)) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" already exists", (char *) NULL); - return TCL_ERROR; - } else if (varPtr->tracePtr != NULL) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" has traces: can't use for upvar", (char *) NULL); - return TCL_ERROR; - } - } - varPtr->flags = (varPtr->flags & ~VAR_UNDEFINED) | VAR_UPVAR; - varPtr->value.upvarPtr = otherPtr; - otherPtr->refCount++; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UpVar -- - * - * Delete a variable, so that it may not be accessed anymore. - * - * Results: - * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR - * if the variable can't be unset. In the event of an error, - * if the TCL_LEAVE_ERR_MSG flag is set then an error message - * is left in interp->result. - * - * Side effects: - * If varName is defined as a local or global variable in interp, - * it is deleted. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_UpVar( - Tcl_Interp *interp, /* Command interpreter in which varName is - * to be looked up. */ - char *frameName, /* Name of the frame containing the source - * variable, such as "1" or "#0". */ - char *varName, /* Name of a variable in interp. May be - * either a scalar name or an element - * in an array. */ - char *localName, /* Destination variable name. */ - int flags /* Either 0 or TCL_GLOBAL_ONLY; indicates - * whether localName is local or global. */ -) -{ - int result; - CallFrame *framePtr; - char *p; - - result = TclGetFrame(interp, frameName, &framePtr); - if (result == -1) { - return TCL_ERROR; - } - - /* - * Figure out whether this is an array reference, then call - * Tcl_UpVar2 to do all the real work. - */ - - for (p = varName; *p != '\0'; p++) { - if (*p == '(') { - char *openParen = p; - - do { - p++; - } while (*p != '\0'); - p--; - if (*p != ')') { - goto scalar; - } - *openParen = '\0'; - *p = '\0'; - result = MakeUpvar((Interp *) interp, framePtr, varName, - openParen+1, localName, flags); - *openParen = '('; - *p = ')'; - return result; - } - } - - scalar: - return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL, - localName, flags); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UpVar2 -- - * - * This procedure links one variable to another, just like - * the "upvar" command. - * - * Results: - * A standard Tcl completion code. If an error occurs then - * an error message is left in interp->result. - * - * Side effects: - * The variable in frameName whose name is given by part1 and - * part2 becomes accessible under the name newName, so that - * references to newName are redirected to the other variable - * like a symbolic link. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_UpVar2( - Tcl_Interp *interp, /* Interpreter containing variables. Used - * for error messages too. */ - char *frameName, /* Name of the frame containing the source - * variable, such as "1" or "#0". */ - char *part1, char *part2, /* Two parts of source variable name. */ - char *localName, /* Destination variable name. */ - int flags /* TCL_GLOBAL_ONLY or 0. */ -) -{ - int result; - CallFrame *framePtr; - - result = TclGetFrame(interp, frameName, &framePtr); - if (result == -1) { - return TCL_ERROR; - } - return MakeUpvar((Interp *) interp, framePtr, part1, part2, - localName, flags); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GlobalCmd -- - * - * This procedure is invoked to process the "global" 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_GlobalCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv /* Argument strings. */ -) -{ - Interp *iPtr = (Interp *) interp; - - if (argc < 2) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"", - argv[0], " varName ?varName ...?\"", (char *) NULL); - return TCL_ERROR; - } - if (iPtr->varFramePtr == NULL) { - return TCL_OK; - } - - for (argc--, argv++; argc > 0; argc--, argv++) { - if (MakeUpvar(iPtr, (CallFrame *) NULL, *argv, (char *) NULL, *argv, 0) - != TCL_OK) { - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UpvarCmd -- - * - * This procedure is invoked to process the "upvar" 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_UpvarCmd( - 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 *framePtr; - char *p; - - if (argc < 3) { - upvarSyntax: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?level? otherVar localVar ?otherVar localVar ...?\"", - (char *) NULL); - return TCL_ERROR; - } - - /* - * Find the hash table containing the variable being referenced. - */ - - result = TclGetFrame(interp, argv[1], &framePtr); - if (result == -1) { - return TCL_ERROR; - } - argc -= result+1; - if ((argc & 1) != 0) { - goto upvarSyntax; - } - argv += result+1; - - /* - * Iterate over all the pairs of (other variable, local variable) - * names. For each pair, divide the other variable name into two - * parts, then call MakeUpvar to do all the work of creating linking - * it to the local variable. - */ - - for ( ; argc > 0; argc -= 2, argv += 2) { - for (p = argv[0]; *p != 0; p++) { - if (*p == '(') { - char *openParen = p; - - do { - p++; - } while (*p != '\0'); - p--; - if (*p != ')') { - goto scalar; - } - *openParen = '\0'; - *p = '\0'; - result = MakeUpvar(iPtr, framePtr, argv[0], openParen+1, - argv[1], 0); - *openParen = '('; - *p = ')'; - goto checkResult; - } - } - scalar: - result = MakeUpvar(iPtr, framePtr, argv[0], (char *) NULL, argv[1], 0); - - checkResult: - if (result != TCL_OK) { - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CallTraces -- - * - * This procedure is invoked to find and invoke relevant - * trace procedures associated with a particular operation on - * a variable. This procedure invokes traces both on the - * variable and on its containing array (where relevant). - * - * Results: - * The return value is NULL if no trace procedures were invoked, or - * if all the invoked trace procedures returned successfully. - * The return value is non-zero if a trace procedure returned an - * error (in this case no more trace procedures were invoked after - * the error was returned). In this case the return value is a - * pointer to a static string describing the error. - * - * Side effects: - * Almost anything can happen, depending on trace; this procedure - * itself doesn't have any side effects. - * - *---------------------------------------------------------------------- - */ - -static char * -CallTraces( - Interp *iPtr, /* Interpreter containing variable. */ - Var *arrayPtr, /* Pointer to array variable that - * contains the variable, or NULL if - * the variable isn't an element of an - * array. */ - Var *varPtr, /* Variable whose traces are to be - * invoked. */ - char *part1, char *part2, /* Variable's two-part name. */ - int flags /* Flags to pass to trace procedures: - * indicates what's happening to - * variable, plus other stuff like - * TCL_GLOBAL_ONLY and - * TCL_INTERP_DESTROYED. May also - * contain PART1_NOT_PARSEd, which - * should not be passed through - * to callbacks. */ -) -{ - VarTrace *tracePtr; - ActiveVarTrace active; - char *result, *openParen, *p; - Tcl_DString nameCopy; - int copiedName; - - /* - * If there are already similar trace procedures active for the - * variable, don't call them again. - */ - - if (varPtr->flags & VAR_TRACE_ACTIVE) { - return NULL; - } - varPtr->flags |= VAR_TRACE_ACTIVE; - varPtr->refCount++; - - /* - * If the variable name hasn't been parsed into array name and - * element, do it here. If there really is an array element, - * make a copy of the original name so that NULLs can be - * inserted into it to separate the names (can't modify the name - * string in place, because the string might get used by the - * callbacks we invoke). - */ - - copiedName = 0; - if (flags & PART1_NOT_PARSED) { - for (p = part1; ; p++) { - if (*p == 0) { - break; - } - if (*p == '(') { - openParen = p; - do { - p++; - } while (*p != '\0'); - p--; - if (*p == ')') { - Tcl_DStringInit(&nameCopy); - Tcl_DStringAppend(&nameCopy, part1, (p-part1)); - part2 = Tcl_DStringValue(&nameCopy) - + (openParen + 1 - part1); - part2[-1] = 0; - part1 = Tcl_DStringValue(&nameCopy); - copiedName = 1; - } - break; - } - } - } - flags &= ~PART1_NOT_PARSED; - - /* - * Invoke traces on the array containing the variable, if relevant. - */ - - result = NULL; - active.nextPtr = iPtr->activeTracePtr; - iPtr->activeTracePtr = &active; - if (arrayPtr != NULL) { - arrayPtr->refCount++; - active.varPtr = arrayPtr; - for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { - active.nextTracePtr = tracePtr->nextPtr; - if (!(tracePtr->flags & flags)) { - continue; - } - result = (*tracePtr->traceProc)(tracePtr->clientData, - (Tcl_Interp *) iPtr, part1, part2, flags); - if (result != NULL) { - if (flags & TCL_TRACE_UNSETS) { - result = NULL; - } else { - goto done; - } - } - } - } - - /* - * Invoke traces on the variable itself. - */ - - if (flags & TCL_TRACE_UNSETS) { - flags |= TCL_TRACE_DESTROYED; - } - active.varPtr = varPtr; - for (tracePtr = varPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { - active.nextTracePtr = tracePtr->nextPtr; - if (!(tracePtr->flags & flags)) { - continue; - } - result = (*tracePtr->traceProc)(tracePtr->clientData, - (Tcl_Interp *) iPtr, part1, part2, flags); - if (result != NULL) { - if (flags & TCL_TRACE_UNSETS) { - result = NULL; - } else { - goto done; - } - } - } - - /* - * Restore the variable's flags, remove the record of our active - * traces, and then return. - */ - - done: - if (arrayPtr != NULL) { - arrayPtr->refCount--; - } - if (copiedName) { - Tcl_DStringFree(&nameCopy); - } - varPtr->flags &= ~VAR_TRACE_ACTIVE; - varPtr->refCount--; - iPtr->activeTracePtr = active.nextPtr; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * NewVar -- - * - * Create a new variable with a given amount of storage - * space. - * - * Results: - * The return value is a pointer to the new variable structure. - * The variable will not be part of any hash table yet. Its - * initial value is empty. - * - * Side effects: - * Storage gets allocated. - * - *---------------------------------------------------------------------- - */ - -static Var * -NewVar(void) -{ - Var *varPtr; - - varPtr = (Var *) ckalloc(sizeof(Var)); - varPtr->valueLength = 0; - varPtr->valueSpace = 0; - varPtr->value.string = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = VAR_UNDEFINED; - return varPtr; -} - -/* - *---------------------------------------------------------------------- - * - * ParseSearchId -- - * - * This procedure translates from a string to a pointer to an - * active array search (if there is one that matches the string). - * - * Results: - * The return value is a pointer to the array search indicated - * by string, or NULL if there isn't one. If NULL is returned, - * interp->result contains an error message. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static ArraySearch * -ParseSearchId( - Tcl_Interp *interp, /* Interpreter containing variable. */ - Var *varPtr, /* Array variable search is for. */ - char *varName, /* Name of array variable that search is - * supposed to be for. */ - char *string /* String containing id of search. Must have - * form "search-num-var" where "num" is a - * decimal number and "var" is a variable - * name. */ -) -{ - char *end; - int id; - ArraySearch *searchPtr; - - /* - * Parse the id into the three parts separated by dashes. - */ - - if ((string[0] != 's') || (string[1] != '-')) { - syntax: - Tcl_AppendResult(interp, "illegal search identifier \"", string, - "\"", (char *) NULL); - return NULL; - } - id = strtoul(string+2, &end, 10); - if ((end == (string+2)) || (*end != '-')) { - goto syntax; - } - if (strcmp(end+1, varName) != 0) { - Tcl_AppendResult(interp, "search identifier \"", string, - "\" isn't for variable \"", varName, "\"", (char *) NULL); - return NULL; - } - - /* - * Search through the list of active searches on the interpreter - * to see if the desired one exists. - */ - - for (searchPtr = varPtr->searchPtr; searchPtr != NULL; - searchPtr = searchPtr->nextPtr) { - if (searchPtr->id == id) { - return searchPtr; - } - } - Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", - (char *) NULL); - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteSearches -- - * - * This procedure is called to free up all of the searches - * associated with an array variable. - * - * Results: - * None. - * - * Side effects: - * Memory is released to the storage allocator. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteSearches( - Var *arrayVarPtr /* Variable whose searches are - * to be deleted. */ -) -{ - ArraySearch *searchPtr; - - while (arrayVarPtr->searchPtr != NULL) { - searchPtr = arrayVarPtr->searchPtr; - arrayVarPtr->searchPtr = searchPtr->nextPtr; - ckfree((char *) searchPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclDeleteVars -- - * - * This procedure is called to recycle all the storage space - * associated with a table of variables. For this procedure - * to work correctly, it must not be possible for any of the - * variable in the table to be accessed from Tcl commands - * (e.g. from trace procedures). - * - * Results: - * None. - * - * Side effects: - * Variables are deleted and trace procedures are invoked, if - * any are declared. - * - *---------------------------------------------------------------------- - */ - -void -TclDeleteVars( - Interp *iPtr, /* Interpreter to which variables belong. */ - Tcl_HashTable *tablePtr /* Hash table containing variables to - * delete. */ -) -{ - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - Var *varPtr; - Var *upvarPtr; - int flags; - ActiveVarTrace *activePtr; - - flags = TCL_TRACE_UNSETS; - if (tablePtr == &iPtr->globalTable) { - flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY; - } - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - - /* - * For global/upvar variables referenced in procedures, decrement - * the reference count on the variable referred to, and free - * the referenced variable if it's no longer needed. Don't delete - * the hash entry for the other variable if it's in the same table - * as us: this will happen automatically later on. - */ - - if (varPtr->flags & VAR_UPVAR) { - upvarPtr = varPtr->value.upvarPtr; - upvarPtr->refCount--; - if ((upvarPtr->refCount == 0) && (upvarPtr->flags & VAR_UNDEFINED) - && (upvarPtr->tracePtr == NULL)) { - if (upvarPtr->hPtr == NULL) { - ckfree((char *) upvarPtr); - } else if (upvarPtr->hPtr->tablePtr != tablePtr) { - Tcl_DeleteHashEntry(upvarPtr->hPtr); - ckfree((char *) upvarPtr); - } - } - } - - /* - * Invoke traces on the variable that is being deleted, then - * free up the variable's space (no need to free the hash entry - * here, unless we're dealing with a global variable: the - * hash entries will be deleted automatically when the whole - * table is deleted). - */ - - if (varPtr->tracePtr != NULL) { - (void) CallTraces(iPtr, (Var *) NULL, varPtr, - Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL, flags); - while (varPtr->tracePtr != NULL) { - VarTrace *tracePtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); - } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { - if (activePtr->varPtr == varPtr) { - activePtr->nextTracePtr = NULL; - } - } - } - if (varPtr->flags & VAR_ARRAY) { - DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags); - } - if (varPtr->valueSpace > 0) { - /* - * SPECIAL TRICK: it's possible that the interpreter's result - * currently points to this variable (for example, a "set" or - * "lappend" command was the last command in a procedure that's - * being returned from). If this is the case, then just pass - * ownership of the value string to the Tcl interpreter. - */ - - if (iPtr->result == varPtr->value.string) { - iPtr->freeProc = TCL_DYNAMIC; - } else { - ckfree(varPtr->value.string); - } - varPtr->valueSpace = 0; - } - varPtr->hPtr = NULL; - varPtr->tracePtr = NULL; - varPtr->flags = VAR_UNDEFINED; - - /* - * Recycle the variable's memory space if there aren't any upvar's - * pointing to it. If there are upvars, then the variable will - * get freed when the last upvar goes away. - */ - - if (varPtr->refCount == 0) { - ckfree((char *) varPtr); - } - } - Tcl_DeleteHashTable(tablePtr); -} - -/* - *---------------------------------------------------------------------- - * - * DeleteArray -- - * - * This procedure is called to free up everything in an array - * variable. It's the caller's responsibility to make sure - * that the array is no longer accessible before this procedure - * is called. - * - * Results: - * None. - * - * Side effects: - * All storage associated with varPtr's array elements is deleted - * (including the hash table). Delete trace procedures for - * array elements are invoked. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteArray( - Interp *iPtr, /* Interpreter containing array. */ - char *arrayName, /* Name of array (used for trace - * callbacks). */ - Var *varPtr, /* Pointer to variable structure. */ - int flags /* Flags to pass to CallTraces: - * TCL_TRACE_UNSETS and sometimes - * TCL_INTERP_DESTROYED and/or - * TCL_GLOBAL_ONLY. */ -) -{ - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - Var *elPtr; - ActiveVarTrace *activePtr; - - DeleteSearches(varPtr); - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - elPtr = (Var *) Tcl_GetHashValue(hPtr); - if (elPtr->valueSpace != 0) { - /* - * SPECIAL TRICK: it's possible that the interpreter's result - * currently points to this element (for example, a "set" or - * "lappend" command was the last command in a procedure that's - * being returned from). If this is the case, then just pass - * ownership of the value string to the Tcl interpreter. - */ - - if (iPtr->result == elPtr->value.string) { - iPtr->freeProc = TCL_DYNAMIC; - } else { - ckfree(elPtr->value.string); - } - elPtr->valueSpace = 0; - } - elPtr->hPtr = NULL; - if (elPtr->tracePtr != NULL) { - elPtr->flags &= ~VAR_TRACE_ACTIVE; - (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName, - Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags); - while (elPtr->tracePtr != NULL) { - VarTrace *tracePtr = elPtr->tracePtr; - elPtr->tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); - } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { - if (activePtr->varPtr == elPtr) { - activePtr->nextTracePtr = NULL; - } - } - } - elPtr->flags = VAR_UNDEFINED; - if (elPtr->refCount == 0) { - ckfree((char *) elPtr); - } - } - Tcl_DeleteHashTable(varPtr->value.tablePtr); - ckfree((char *) varPtr->value.tablePtr); -} - -/* - *---------------------------------------------------------------------- - * - * CleanupVar -- - * - * This procedure is called when it looks like it may be OK - * to free up the variable's record and hash table entry, and - * those of its containing parent. It's called, for example, - * when a trace on a variable deletes the variable. - * - * Results: - * None. - * - * Side effects: - * If the variable (or its containing array) really is dead then - * its record, and possibly its hash table entry, gets freed up. - * - *---------------------------------------------------------------------- - */ - -static void -CleanupVar( - Var *varPtr, /* Pointer to variable that may be a - * candidate for being expunged. */ - Var *arrayPtr /* Array that contains the variable, or - * NULL if this variable isn't an array - * element. */ -) -{ - if ((varPtr->flags & VAR_UNDEFINED) && (varPtr->refCount == 0) - && (varPtr->tracePtr == NULL)) { - if (varPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(varPtr->hPtr); - } - ckfree((char *) varPtr); - } - if (arrayPtr != NULL) { - if ((arrayPtr->flags & VAR_UNDEFINED) && (arrayPtr->refCount == 0) - && (arrayPtr->tracePtr == NULL)) { - if (arrayPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(arrayPtr->hPtr); - } - ckfree((char *) arrayPtr); - } - } - return; -} - -/* - *---------------------------------------------------------------------- - * - * VarErrMsg -- - * - * Generate a reasonable error message describing why a variable - * operation failed. - * - * Results: - * None. - * - * Side effects: - * Interp->result is reset to hold a message identifying the - * variable given by part1 and part2 and describing why the - * variable operation failed. - * - *---------------------------------------------------------------------- - */ - -static void -VarErrMsg( - Tcl_Interp *interp, /* Interpreter in which to record message. */ - char *part1, char *part2, /* Variable's two-part name. */ - char *operation, /* String describing operation that failed, - * e.g. "read", "set", or "unset". */ - char *reason /* String describing why operation failed. */ -) -{ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't ", operation, " \"", part1, (char *) NULL); - if (part2 != NULL) { - Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); - } - Tcl_AppendResult(interp, "\": ", reason, (char *) NULL); -}