+++ /dev/null
-XCOMM $XConsortium: Imakefile /main/4 1996/08/08 14:42:19 cde-hp $
-#define DoNormalLib YES
-#define DoSharedLib NO
-#define DoDebugLib NO
-#define DoProfileLib NO
-#define LibName tcl
-#define LibHeaders NO
-#define LibInstall NO
-
-VERSION = 8.5
-
-#if defined(LinuxArchitecture)
-prefix = /usr/lib
-#elif defined(OpenBSDArchitecture)
-prefix = /usr/local/lib/tcl
-#elif defined(NetBSDArchitecture)
-prefix = /usr/pkg/lib
-#else
-prefix = /usr/local/lib
-#endif
-
-XCOMM Directory from which applications will reference the library of Tcl
-XCOMM scripts (note: you can set the TCL_LIBRARY environment variable at
-XCOMM run-time to override this value):
-#ifdef TclLibrary
-TCL_LIBRARY = TclLibrary
-#else
-TCL_LIBRARY = $(prefix)/tcl$(VERSION)
-#endif
-
-DEPEND_DEFINES = $(DEPENDDEFINES)
-
-#if defined(SunArchitecture)
-EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
- -DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR \
- -DTCL_GOT_TIMEZONE
-
-#elif defined(IBMArchitecture)
-EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
- -DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR -Dvfork=fork \
- -DTCL_GOT_TIMEZONE -DHAVE_SYS_SELECT_H
-
-#elif defined(AlphaArchitecture)
-EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
- -DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR \
- -DTCL_GOT_TIMEZONE -DTIME_WITH_SYS_TIME
-
-#elif defined(OpenBSDArchitecture)
-EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
- -DNO_UNION_WAIT -DHAVE_UNISTD_H \
- -DTCL_GOT_TIMEZONE
-
-#elif defined(FreeBSDArchitecture)
-EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
- -DNO_UNION_WAIT -DHAVE_UNISTD_H \
- -DTCL_GOT_TIMEZONE
-
-#elif defined(NetBSDArchitecture)
-EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
- -DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR \
- -DTCL_GOT_TIMEZONE
-
-#else
-EXTRA_DEFINES = -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
- -DNO_UNION_WAIT -DHAVE_UNISTD_H -DNEED_MATHERR \
- -DTCL_GOT_TIMEZONE
-#endif
-
-INCLUDES = -I.
-
-SRCS = panic.c regexp.c tclAsync.c tclBasic.c tclCkalloc.c \
- tclClock.c tclCmdAH.c tclCmdIL.c tclCmdMZ.c tclDate.c \
- tclEnv.c tclEvent.c tclExpr.c tclFHandle.c tclFileName.c \
- tclGet.c tclHash.c tclHistory.c tclIO.c tclIOCmd.c \
- tclIOSock.c tclIOUtil.c tclInterp.c tclLink.c tclLoad.c \
- tclLoadNone.c tclMain.c tclMtherr.c tclNotify.c tclParse.c \
- tclPkg.c tclPosixStr.c tclPreserve.c tclProc.c \
- tclUnixChan.c tclUnixFile.c tclUnixInit.c tclUnixNotfy.c \
- tclUnixPipe.c tclUnixSock.c tclUnixTime.c tclUtil.c \
- tclVar.c
-
-OBJS = panic.o regexp.o tclAsync.o tclBasic.o tclCkalloc.o \
- tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclDate.o \
- tclEnv.o tclEvent.o tclExpr.o tclFHandle.o tclFileName.o \
- tclGet.o tclHash.o tclHistory.o tclIO.o tclIOCmd.o \
- tclIOSock.o tclIOUtil.o tclInterp.o tclLink.o tclLoad.o \
- tclLoadNone.o tclMain.o tclMtherr.o tclNotify.o tclParse.o \
- tclPkg.o tclPosixStr.o tclPreserve.o tclProc.o \
- tclUnixChan.o tclUnixFile.o tclUnixInit.o tclUnixNotfy.o \
- tclUnixPipe.o tclUnixSock.o tclUnixTime.o tclUtil.o \
- tclVar.o
-
-#include <Library.tmpl>
-
-DependTarget()
+++ /dev/null
-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.
+++ /dev/null
-/*
- * CDE - Common Desktop Environment
- *
- * Copyright (c) 1993-2012, The Open Group. All rights reserved.
- *
- * These libraries and programs are free software; you can
- * redistribute them and/or modify them under the terms of the GNU
- * Lesser General Public License as published by the Free Software
- * Foundation; either version 2 of the License, or (at your option)
- * any later version.
- *
- * These libraries and programs are distributed in the hope that
- * they will be useful, but WITHOUT ANY WARRANTY; without even the
- * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
- * PURPOSE. See the GNU Lesser General Public License for more
- * details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with these libraries and programs; if not, write
- * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
- * Floor, Boston, MA 02110-1301 USA
- */
-/* $XConsortium: panic.c /main/2 1996/08/08 14:42:24 cde-hp $ */
-/*
- * panic.c --
- *
- * Source code for the "panic" library procedure for Tcl;
- * individual applications will probably override this with
- * an application-specific panic procedure.
- *
- * Copyright (c) 1988-1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) panic.c 1.11 96/02/15 11:50:29
- */
-
-#include <stdio.h>
-#ifdef NO_STDLIB_H
-# include "../compat/stdlib.h"
-#else
-# include <stdlib.h>
-#endif
-
-#include "tcl.h"
-
-/*
- * The panicProc variable contains a pointer to an application
- * specific panic procedure.
- */
-
-void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL;
-
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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();
- }
-}
+++ /dev/null
-/*
- * 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"
+++ /dev/null
-/*
- * 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
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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 <stdio.h>
-#endif
-
-#include <sys/types.h> /* 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 */
+++ /dev/null
-/*
- * 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;
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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}
-};
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *-----------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_InitMemory --
- * Initialize the memory command.
- *
- *----------------------------------------------------------------------
- */
-void
-Tcl_InitMemory(interp)
- Tcl_Interp *interp;
-{
-Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,
- (Tcl_CmdDeleteProc *) NULL);
-}
-
-#else
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-
-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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *-----------------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *-----------------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *-----------------------------------------------------------------------------
- *
- * 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;
-}
-
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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! */
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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";
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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<numLists ; i++) {
- index[i] = 0;
- varcList[i] = 0;
- varvList[i] = (char **)NULL;
- argcList[i] = 0;
- argvList[i] = (char **)NULL;
- }
-
- /*
- * Break up the value lists and variable lists into elements
- */
-
- maxj = 0;
- for (i=0 ; i<numLists ; i++) {
- result = Tcl_SplitList(interp, argv[1+i*2], &varcList[i], &varvList[i]);
- if (result != TCL_OK) {
- goto errorReturn;
- }
- result = Tcl_SplitList(interp, argv[2+i*2], &argcList[i], &argvList[i]);
- if (result != TCL_OK) {
- goto errorReturn;
- }
- j = argcList[i] / varcList[i];
- if ((argcList[i] % varcList[i]) != 0) {
- j++;
- }
- if (j > 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 ; i<numLists ; i++) {
- for (v=0 ; v<varcList[i] ; v++) {
- int k = index[i]++;
- char *value = "";
- if (k < argcList[i]) {
- value = argvList[i][k];
- }
- if (Tcl_SetVar(interp, varvList[i][v], value, 0) == NULL) {
- Tcl_AppendResult(interp, "couldn't set loop variable: \"",
- varvList[i][v], "\"", (char *)NULL);
- result = TCL_ERROR;
- goto errorReturn;
- }
- }
- }
-
- result = Tcl_Eval(interp, argv[argc-1]);
- if (result != TCL_OK) {
- if (result == TCL_CONTINUE) {
- result = TCL_OK;
- } else if (result == TCL_BREAK) {
- result = TCL_OK;
- break;
- } else if (result == TCL_ERROR) {
- char msg[100];
- sprintf(msg, "\n (\"foreach\" body line %d)",
- interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
- break;
- } else {
- break;
- }
- }
- }
- if (result == TCL_OK) {
- Tcl_ResetResult(interp);
- }
-errorReturn:
- for (i=0 ; i<numLists ; i++) {
- if (argvList[i] != (char **)NULL) {
- ckfree((char *) argvList[i]);
- }
- if (varvList[i] != (char **)NULL) {
- ckfree((char *) varvList[i]);
- }
- }
- if (numLists > STATIC_SIZE) {
- ckfree((char *) index);
- ckfree((char *) varcList);
- ckfree((char *) argcList);
- ckfree((char *) varvList);
- ckfree((char *) argvList);
- }
-#undef STATIC_SIZE
- return result;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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]);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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]);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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<i ){
- first = mid + 1;
- }else{
- last = mid -1;
- }
- }
- /*No entry in the table.*/
- return i;/* Giving up.*/
- }else{/* i is already a token. */
- return i;
- }
-}
-#else/*!YYNMBCHARS*/
-#define YYLEX() TclDatelex()
-#endif/*!YYNMBCHARS*/
-
-/*
-** TclDateparse - return 0 if worked, 1 if syntax error not recovered from
-*/
-#if defined(__STDC__) || defined(__cplusplus)
-int TclDateparse(void)
-#else
-int TclDateparse()
-#endif
-{
- YYSTYPE *TclDatepvt; /* top of value stack for $vars */
-
-#if defined(__cplusplus) || defined(lint)
-/*
- hacks to please C++ and lint - goto's inside switch should never be
- executed; TclDatepvt is set to 0 to avoid "used before set" warning.
-*/
- static int __yaccpar_lint_hack__ = 0;
- switch (__yaccpar_lint_hack__)
- {
- case 1: goto TclDateerrlab;
- case 2: goto TclDatenewstate;
- }
- TclDatepvt = 0;
-#endif
-
- /*
- ** Initialize externals - TclDateparse may be called more than once
- */
- TclDatepv = &TclDatev[-1];
- TclDateps = &TclDates[-1];
- TclDatestate = 0;
- TclDatetmp = 0;
- TclDatenerrs = 0;
- TclDateerrflag = 0;
- TclDatechar = -1;
-
-#if YYMAXDEPTH <= 0
- if (TclDatemaxdepth <= 0)
- {
- if ((TclDatemaxdepth = YYEXPAND(0)) <= 0)
- {
- TclDateerror("yacc initialization error");
- YYABORT;
- }
- }
-#endif
-
- {
- YYSTYPE *TclDate_pv; /* top of value stack */
- int *TclDate_ps; /* top of state stack */
- int TclDate_state; /* current state */
- int TclDate_n; /* internal state number info */
- goto TclDatestack; /* moved from 6 lines above to here to please C++ */
-
- /*
- ** get globals into registers.
- ** branch to here only if YYBACKUP was called.
- */
- TclDate_pv = TclDatepv;
- TclDate_ps = TclDateps;
- TclDate_state = TclDatestate;
- goto TclDate_newstate;
-
- /*
- ** get globals into registers.
- ** either we just started, or we just finished a reduction
- */
- TclDatestack:
- TclDate_pv = TclDatepv;
- TclDate_ps = TclDateps;
- TclDate_state = TclDatestate;
-
- /*
- ** top of for (;;) loop while no reductions done
- */
- TclDate_stack:
- /*
- ** put a state and value onto the stacks
- */
-#if YYDEBUG
- /*
- ** if debugging, look up token value in list of value vs.
- ** name pairs. 0 and negative (-1) are special values.
- ** Note: linear search is used since time is not a real
- ** consideration while debugging.
- */
- if ( TclDatedebug )
- {
- int TclDate_i;
-
- printf( "State %d, token ", TclDate_state );
- 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_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 */
-}
-
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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 <float.h>
-#endif
-#ifndef TCL_NO_MATH
-#include <math.h>
-#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},
-};
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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];
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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 "~<user>" (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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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"
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- };
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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++;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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 */
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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"
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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 */
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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 <stdio.h>
-#include <stdint.h>
-
-#include <sys/types.h> /* for pid_t */
-
-#ifndef _TCL
-#include "tcl.h"
-#endif
-#ifndef _REGEXP
-#include "tclRegexp.h"
-#endif
-
-#include <ctype.h>
-#ifdef NO_LIMITS_H
-# include "../compat/limits.h"
-#else
-# include <limits.h>
-#endif
-#ifdef NO_STDLIB_H
-# include "../compat/stdlib.h"
-#else
-# include <stdlib.h>
-#endif
-#ifdef NO_STRING_H
-#include "../compat/string.h"
-#else
-#include <string.h>
-#endif
-#if defined(__STDC__) || defined(HAS_STDARG)
-# include <stdarg.h>
-#else
-# include <varargs.h>
-#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 */
+++ /dev/null
-/*
- * 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 <stdio.h>
-#include "tclInt.h"
-#include "tclPort.h"
-\f
-/*
- * 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));
-\f
-/*
- * 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 ;
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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 */
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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 "??";
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
+++ /dev/null
-/*
- * 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"
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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
+++ /dev/null
-/*
- * CDE - Common Desktop Environment
- *
- * Copyright (c) 1993-2012, The Open Group. All rights reserved.
- *
- * These libraries and programs are free software; you can
- * redistribute them and/or modify them under the terms of the GNU
- * Lesser General Public License as published by the Free Software
- * Foundation; either version 2 of the License, or (at your option)
- * any later version.
- *
- * These libraries and programs are distributed in the hope that
- * they will be useful, but WITHOUT ANY WARRANTY; without even the
- * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
- * PURPOSE. See the GNU Lesser General Public License for more
- * details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with these libraries and programs; if not, write
- * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
- * Floor, Boston, MA 02110-1301 USA
- */
-/* $XConsortium: tclMtherr.c /main/2 1996/08/08 14:45:38 cde-hp $ */
-/*
- * tclMatherr.c --
- *
- * This function provides a default implementation of the
- * "matherr" function, for SYS-V systems where it's needed.
- *
- * Copyright (c) 1993-1994 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) tclMtherr.c 1.11 96/02/15 11:58:36
- */
-
-#include "tclInt.h"
-#include <math.h>
-
-#ifndef TCL_GENERIC_ONLY
-#include "tclPort.h"
-#else
-#define NO_ERRNO_H
-#endif
-
-#ifdef NO_ERRNO_H
-extern int errno; /* Use errno from tclExpr.c. */
-#define EDOM 33
-#define ERANGE 34
-#endif
-
-/*
- * The following variable is secretly shared with Tcl so we can
- * tell if expression evaluation is in progress. If not, matherr
- * just emulates the default behavior, which includes printing
- * a message.
- */
-
-extern int tcl_MathInProgress;
-
-/*
- * The following definitions allow matherr to compile on systems
- * that don't really support it. The compiled procedure is bogus,
- * but it will never be executed on these systems anyway.
- */
-#if defined(__linux__) && defined(__GLIBC__)
-# include <features.h>
-/* glibc removed matherr() support between 2.26 and 2.27 */
-# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 27) || __GLIBC__ >= 3
-# undef NEED_MATHERR
-# endif
-#endif /* linux */
-
-#ifndef NEED_MATHERR
-struct exception {
- int type;
-};
-#define DOMAIN 0
-#define SING 0
-#endif
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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++;
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
+++ /dev/null
-/*
- * 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 */
+++ /dev/null
-/*
- * 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"
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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";
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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";
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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";
-}
+++ /dev/null
-/*
- * 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));
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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 */
+++ /dev/null
-/*
- * 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. */
-};
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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. */
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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));
- }
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * CDE - Common Desktop Environment
- *
- * Copyright (c) 1993-2012, The Open Group. All rights reserved.
- *
- * These libraries and programs are free software; you can
- * redistribute them and/or modify them under the terms of the GNU
- * Lesser General Public License as published by the Free Software
- * Foundation; either version 2 of the License, or (at your option)
- * any later version.
- *
- * These libraries and programs are distributed in the hope that
- * they will be useful, but WITHOUT ANY WARRANTY; without even the
- * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
- * PURPOSE. See the GNU Lesser General Public License for more
- * details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with these libraries and programs; if not, write
- * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
- * Floor, Boston, MA 02110-1301 USA
- */
-/* $XConsortium: tclUnixInit.c /main/2 1996/08/08 14:46:42 cde-hp $ */
-/*
- * tclUnixInit.c --
- *
- * Contains the Unix-specific interpreter initialization functions.
- *
- * Copyright (c) 1995-1996 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) tclUnixInit.c 1.10 96/03/12 09:05:59
- */
-
-#include "tclInt.h"
-#include "tclPort.h"
-#ifndef NO_UNAME
-# include <sys/utsname.h>
-#endif
-#if defined(__FreeBSD__)
-#include <floatingpoint.h>
-#endif
-
-/*
- * Default directory in which to look for libraries:
- */
-
-static char defaultLibraryDir[200] = TCL_LIBRARY;
-
-/*
- * The following string is the startup script executed in new
- * interpreters. It looks on disk in several different directories
- * for a script "init.tcl" that is compatible with this version
- * of Tcl. The init.tcl script does all of the real work of
- * initialization.
- */
-
-static char *initScript =
-"proc init {} {\n\
- global tcl_library tcl_version tcl_patchLevel env\n\
- rename init {}\n\
- set dirs {}\n\
- if [info exists env(TCL_LIBRARY)] {\n\
- lappend dirs $env(TCL_LIBRARY)\n\
- }\n\
- lappend dirs [info library]\n\
- lappend dirs [file dirname [file dirname [info nameofexecutable]]]/lib/tcl$tcl_version\n\
- if [string match {*[ab]*} $tcl_patchLevel] {\n\
- set lib tcl$tcl_patchLevel\n\
- } else {\n\
- set lib tcl$tcl_version\n\
- }\n\
- lappend dirs [file dirname [file dirname [pwd]]]/$lib/library\n\
- lappend dirs [file dirname [pwd]]/library\n\
- foreach i $dirs {\n\
- set tcl_library $i\n\
- if ![catch {uplevel #0 source $i/init.tcl}] {\n\
- return\n\
- }\n\
- }\n\
- set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
- append msg \" $dirs\n\"\n\
- append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
- error $msg\n\
-}\n\
-init";
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
+++ /dev/null
-/*
- * CDE - Common Desktop Environment
- *
- * Copyright (c) 1993-2012, The Open Group. All rights reserved.
- *
- * These libraries and programs are free software; you can
- * redistribute them and/or modify them under the terms of the GNU
- * Lesser General Public License as published by the Free Software
- * Foundation; either version 2 of the License, or (at your option)
- * any later version.
- *
- * These libraries and programs are distributed in the hope that
- * they will be useful, but WITHOUT ANY WARRANTY; without even the
- * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
- * PURPOSE. See the GNU Lesser General Public License for more
- * details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with these libraries and programs; if not, write
- * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
- * Floor, Boston, MA 02110-1301 USA
- */
-/* $TOG: tclUnixNotfy.c /main/3 1998/04/06 13:37:34 mgreess $ */
-/*
- * tclUnixNotify.c --
- *
- * This file contains Unix-specific procedures for the notifier,
- * which is the lowest-level part of the Tcl event loop. This file
- * works together with ../generic/tclNotify.c.
- *
- * Copyright (c) 1995 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) tclUnixNotfy.c 1.30 96/03/22 12:45:31
- */
-
-#include "tclInt.h"
-#include "tclPort.h"
-#include <signal.h>
-#include <sys/time.h>
-
-/*
- * The information below is used to provide read, write, and
- * exception masks to select during calls to Tcl_DoOneEvent.
- */
-
-static fd_mask checkMasks[3*MASK_SIZE];
- /* This array is used to build up the masks
- * to be used in the next call to select.
- * Bits are set in response to calls to
- * Tcl_WatchFile. */
-static fd_mask readyMasks[3*MASK_SIZE];
- /* This array reflects the readable/writable
- * conditions that were found to exist by the
- * last call to select. */
-static int numFdBits; /* Number of valid bits in checkMasks
- * (one more than highest fd for which
- * Tcl_WatchFile has been called). */
-
-/*
- * Static routines in this file:
- */
-
-static int MaskEmpty _ANSI_ARGS_((long *maskPtr));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * CDE - Common Desktop Environment
- *
- * Copyright (c) 1993-2012, The Open Group. All rights reserved.
- *
- * These libraries and programs are free software; you can
- * redistribute them and/or modify them under the terms of the GNU
- * Lesser General Public License as published by the Free Software
- * Foundation; either version 2 of the License, or (at your option)
- * any later version.
- *
- * These libraries and programs are distributed in the hope that
- * they will be useful, but WITHOUT ANY WARRANTY; without even the
- * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
- * PURPOSE. See the GNU Lesser General Public License for more
- * details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with these libraries and programs; if not, write
- * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
- * Floor, Boston, MA 02110-1301 USA
- */
-/* $XConsortium: tclUnixPort.h /main/2 1996/08/08 14:46:57 cde-hp $ */
-/*
- * tclUnixPort.h --
- *
- * This header file handles porting issues that occur because
- * of differences between systems. It reads in UNIX-related
- * header files and sets up UNIX-related macros for Tcl's UNIX
- * core. It should be the only file that contains #ifdefs to
- * handle different flavors of UNIX. This file sets up the
- * union of all UNIX-related things needed by any of the Tcl
- * core files. This file depends on configuration #defines such
- * as NO_DIRENT_H that are set up by the "configure" script.
- *
- * Much of the material in this file was originally contributed
- * by Karl Lehenbauer, Mark Diekhans and Peter da Silva.
- *
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1995 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) tclUnixPort.h 1.33 96/03/25 17:15:21
- */
-
-#ifndef _TCLUNIXPORT
-#define _TCLUNIXPORT
-
-#ifndef _TCLINT
-# include "tclInt.h"
-#endif
-#include <errno.h>
-#include <fcntl.h>
-#ifdef HAVE_NET_ERRNO_H
-# include <net/errno.h>
-#endif
-#include <pwd.h>
-#include <signal.h>
-#include <sys/param.h>
-#include <sys/types.h>
-#ifdef USE_DIRENT2_H
-# include "../compat/dirent2.h"
-#else
-# ifdef NO_DIRENT_H
-# include "../compat/dirent.h"
-# else
-# include <dirent.h>
-# endif
-#endif
-#include <sys/file.h>
-#ifdef HAVE_SYS_SELECT_H
-# include <sys/select.h>
-#endif
-#include <sys/stat.h>
-#if TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-#else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-#endif
-#ifndef NO_SYS_WAIT_H
-# include <sys/wait.h>
-#endif
-#ifdef HAVE_UNISTD_H
-# include <unistd.h>
-#else
-# include "../compat/unistd.h"
-#endif
-
-/*
- * Socket support stuff: This likely needs more work to parameterize for
- * each system.
- */
-
-#include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */
-#include <sys/utsname.h> /* uname system call. */
-#include <netinet/in.h> /* struct in_addr, struct sockaddr_in */
-#include <arpa/inet.h> /* inet_ntoa() */
-#include <netdb.h> /* gethostbyname() */
-
-/*
- * NeXT doesn't define O_NONBLOCK, so #define it here if necessary.
- */
-
-#ifndef O_NONBLOCK
-# define O_NONBLOCK 0x80
-#endif
-
-/*
- * HPUX needs the flag O_NONBLOCK to get the right non-blocking I/O
- * semantics, while most other systems need O_NDELAY. Define the
- * constant NBIO_FLAG to be one of these
- */
-
-#ifdef HPUX
-# define NBIO_FLAG O_NONBLOCK
-#else
-# define NBIO_FLAG O_NDELAY
-#endif
-
-/*
- * The default platform eol translation on Unix is TCL_TRANSLATE_LF:
- */
-
-#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_LF
-
-/*
- * Not all systems declare the errno variable in errno.h. so this
- * file does it explicitly. The list of system error messages also
- * isn't generally declared in a header file anywhere.
- */
-
-extern int errno;
-
-/*
- * The type of the status returned by wait varies from UNIX system
- * to UNIX system. The macro below defines it:
- */
-
-#ifdef _AIX
-# define WAIT_STATUS_TYPE pid_t
-#else
-#ifndef NO_UNION_WAIT
-# define WAIT_STATUS_TYPE union wait
-#else
-# define WAIT_STATUS_TYPE int
-#endif
-#endif
-
-/*
- * Supply definitions for macros to query wait status, if not already
- * defined in header files above.
- */
-
-#ifndef WIFEXITED
-# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0)
-#endif
-
-#ifndef WEXITSTATUS
-# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff)
-#endif
-
-#ifndef WIFSIGNALED
-# define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff)))
-#endif
-
-#ifndef WTERMSIG
-# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f)
-#endif
-
-#ifndef WIFSTOPPED
-# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177)
-#endif
-
-#ifndef WSTOPSIG
-# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff)
-#endif
-
-/*
- * Define constants for waitpid() system call if they aren't defined
- * by a system header file.
- */
-
-#ifndef WNOHANG
-# define WNOHANG 1
-#endif
-#ifndef WUNTRACED
-# define WUNTRACED 2
-#endif
-
-/*
- * Supply macros for seek offsets, if they're not already provided by
- * an include file.
- */
-
-#ifndef SEEK_SET
-# define SEEK_SET 0
-#endif
-
-#ifndef SEEK_CUR
-# define SEEK_CUR 1
-#endif
-
-#ifndef SEEK_END
-# define SEEK_END 2
-#endif
-
-/*
- * The stuff below is needed by the "time" command. If this
- * system has no gettimeofday call, then must use times and the
- * CLK_TCK #define (from sys/param.h) to compute elapsed time.
- * Unfortunately, some systems only have HZ and no CLK_TCK, and
- * some might not even have HZ.
- */
-
-#ifdef NO_GETTOD
-# include <sys/times.h>
-# include <sys/param.h>
-# ifndef CLK_TCK
-# ifdef HZ
-# define CLK_TCK HZ
-# else
-# define CLK_TCK 60
-# endif
-# endif
-#else
-# ifdef HAVE_BSDGETTIMEOFDAY
-# define gettimeofday BSDgettimeofday
-# endif
-#endif
-
-#ifdef GETTOD_NOT_DECLARED
-EXTERN int gettimeofday _ANSI_ARGS_((struct timeval *tp,
- struct timezone *tzp));
-#endif
-
-/*
- * Define access mode constants if they aren't already defined.
- */
-
-#ifndef F_OK
-# define F_OK 00
-#endif
-#ifndef X_OK
-# define X_OK 01
-#endif
-#ifndef W_OK
-# define W_OK 02
-#endif
-#ifndef R_OK
-# define R_OK 04
-#endif
-
-/*
- * Define FD_CLOEEXEC (the close-on-exec flag bit) if it isn't
- * already defined.
- */
-
-#ifndef FD_CLOEXEC
-# define FD_CLOEXEC 1
-#endif
-
-/*
- * On systems without symbolic links (i.e. S_IFLNK isn't defined)
- * define "lstat" to use "stat" instead.
- */
-
-#ifndef S_IFLNK
-# define lstat stat
-#endif
-
-/*
- * Define macros to query file type bits, if they're not already
- * defined.
- */
-
-#ifndef S_ISREG
-# ifdef S_IFREG
-# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
-# else
-# define S_ISREG(m) 0
-# endif
-# endif
-#ifndef S_ISDIR
-# ifdef S_IFDIR
-# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR)
-# else
-# define S_ISDIR(m) 0
-# endif
-# endif
-#ifndef S_ISCHR
-# ifdef S_IFCHR
-# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR)
-# else
-# define S_ISCHR(m) 0
-# endif
-# endif
-#ifndef S_ISBLK
-# ifdef S_IFBLK
-# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK)
-# else
-# define S_ISBLK(m) 0
-# endif
-# endif
-#ifndef S_ISFIFO
-# ifdef S_IFIFO
-# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
-# else
-# define S_ISFIFO(m) 0
-# endif
-# endif
-#ifndef S_ISLNK
-# ifdef S_IFLNK
-# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
-# else
-# define S_ISLNK(m) 0
-# endif
-# endif
-#ifndef S_ISSOCK
-# ifdef S_IFSOCK
-# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK)
-# else
-# define S_ISSOCK(m) 0
-# endif
-# endif
-
-/*
- * Make sure that MAXPATHLEN is defined.
- */
-
-#ifndef MAXPATHLEN
-# ifdef PATH_MAX
-# define MAXPATHLEN PATH_MAX
-# else
-# define MAXPATHLEN 2048
-# endif
-#endif
-
-/*
- * Make sure that L_tmpnam is defined.
- */
-
-#ifndef L_tmpnam
-# define L_tmpnam 100
-#endif
-
-/*
- * The following macro defines the type of the mask arguments to
- * select:
- */
-
-#ifndef NO_FD_SET
-# define SELECT_MASK fd_set
-#else
-# ifndef _AIX
- typedef long fd_mask;
-# endif
-# if defined(_IBMR2)
-# define SELECT_MASK void
-# else
-# define SELECT_MASK int
-# endif
-#endif
-
-/*
- * Define "NBBY" (number of bits per byte) if it's not already defined.
- */
-
-#ifndef NBBY
-# define NBBY 8
-#endif
-
-/*
- * The following macro defines the number of fd_masks in an fd_set:
- */
-
-#ifndef FD_SETSIZE
-# ifdef OPEN_MAX
-# define FD_SETSIZE OPEN_MAX
-# else
-# define FD_SETSIZE 256
-# endif
-#endif
-#if !defined(howmany)
-# define howmany(x, y) (((x)+((y)-1))/(y))
-#endif
-#ifndef NFDBITS
-# define NFDBITS NBBY*sizeof(fd_mask)
-#endif
-#define MASK_SIZE howmany(FD_SETSIZE, NFDBITS)
-
-/*
- * The following function is declared in tclInt.h but doesn't do anything
- * on Unix systems.
- */
-
-#define TclSetSystemEnv(a,b)
-
-/*
- * The following implements the Unix method for exiting the process.
- */
-#define TclPlatformExit(status) exit(status)
-
-/*
- * The following functions always succeeds under Unix.
- */
-
-#define TclHasSockets(interp) (TCL_OK)
-#define TclHasPipes() (1)
-
-/*
- * Variables provided by the C library:
- */
-
-#if defined(_sgi) || defined(__sgi)
-#define environ _environ
-#endif
-extern char **environ;
-
-/*
- * At present (12/91) not all stdlib.h implementations declare strtod.
- * The declaration below is here to ensure that it's declared, so that
- * the compiler won't take the default approach of assuming it returns
- * an int. There's no ANSI prototype for it because there would end
- * up being too many conflicts with slightly-different prototypes.
- */
-
-extern double strtod();
-
-#endif /* _TCLUNIXPORT */
+++ /dev/null
-/*
- * 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;
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * CDE - Common Desktop Environment
- *
- * Copyright (c) 1993-2012, The Open Group. All rights reserved.
- *
- * These libraries and programs are free software; you can
- * redistribute them and/or modify them under the terms of the GNU
- * Lesser General Public License as published by the Free Software
- * Foundation; either version 2 of the License, or (at your option)
- * any later version.
- *
- * These libraries and programs are distributed in the hope that
- * they will be useful, but WITHOUT ANY WARRANTY; without even the
- * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
- * PURPOSE. See the GNU Lesser General Public License for more
- * details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with these libraries and programs; if not, write
- * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
- * Floor, Boston, MA 02110-1301 USA
- */
-/* $TOG: tclUnixTime.c /main/3 1998/04/06 13:37:56 mgreess $ */
-/*
- * tclUnixTime.c --
- *
- * Contains Unix specific versions of Tcl functions that
- * obtain time values from the operating system.
- *
- * Copyright (c) 1995 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) tclUnixTime.c 1.10 96/02/15 11:58:41
- */
-
-#include <sys/time.h>
-#include "tclInt.h"
-#include "tclPort.h"
-\f
-/*
- *-----------------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *-----------------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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
-
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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];
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
+++ /dev/null
-/*
- * 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));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * 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);
-}
projects / oweals / cde.git / commitdiff