diff options
21 files changed, 0 insertions, 3502 deletions
diff --git a/contrib/tcl/README.FreeBSD b/contrib/tcl/README.FreeBSD deleted file mode 100644 index a2436d739f5e..000000000000 --- a/contrib/tcl/README.FreeBSD +++ /dev/null @@ -1,4 +0,0 @@ -Tcl 7.5 - originals can be found at: ftp://ftp.smli.com/pub/tcl - removed subdirectories "win", "mac", "compat" - phk@FreeBSD.org diff --git a/contrib/tcl/doc/CrtModalTmt.3 b/contrib/tcl/doc/CrtModalTmt.3 deleted file mode 100644 index 85f079fc85cc..000000000000 --- a/contrib/tcl/doc/CrtModalTmt.3 +++ /dev/null @@ -1,71 +0,0 @@ -'\" -'\" 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: @(#) CrtModalTmt.3 1.3 96/03/25 20:00:19 -'\" -.so man.macros -.TH Tcl_CreateModalTimeout 3 7.5 Tcl "Tcl Library Procedures" -.BS -.SH NAME -Tcl_CreateModalTimeout, Tcl_DeleteModalTimeout \- special timer for modal operations -.SH SYNOPSIS -.nf -\fB#include <tcl.h>\fR -.sp -\fBTcl_CreateModalTimeout\fR(\fImilliseconds, proc, clientData\fR) -.sp -\fBTcl_DeleteModalTimeout\fR(\fIproc, clientData\fR) -.SH ARGUMENTS -.AS Tcl_TimerToken milliseconds -.AP int milliseconds in -How many milliseconds to wait before invoking \fIproc\fR. -.AP Tcl_TimerProc *proc in -Procedure to invoke after \fImilliseconds\fR have elapsed. -.AP ClientData clientData in -Arbitrary one-word value to pass to \fIproc\fR. -.BE - -.SH DESCRIPTION -.PP -\fBTcl_CreateModalTimeout\fR provides an alternate form of timer -from those provided by \fBTcl_CreateTimerHandler\fR. -These timers are called ``modal'' because they are typically -used in situations where a particular operation must be completed -before the application does anything else. -If such an operation needs a timeout, it cannot use normal timer -events: if normal timer events were processed, arbitrary Tcl scripts -might be invoked via other event handlers, which could interfere with -the completion of the modal operation. -The purpose of modal timers is to allow a single timeout to occur -without allowing any normal timer events to occur. -.PP -\fBTcl_CreateModalTimeout\fR behaves just like \fBTcl_CreateTimerHandler\fR -except that it creates a modal timeout. -Its arguments have the same meaning as for \fBTcl_CreateTimerHandler\fR -and \fIproc\fR is invoked just as for \fBTcl_CreateTimerHandler\fR. -\fBTcl_DeleteModalTimeout\fR deletes the most recently created -modal timeout; its arguments must match the corresponding arguments -to the most recent call to \fBTcl_CreateModalTimeout\fR. -.PP -Modal timeouts differ from a normal timers in three ways. First, -they will trigger regardless of whether the TCL_TIMER_EVENTS flag -has been passed to \fBTcl_DoOneEvent\fR. -Typically modal timers are used with the TCL_TIMER_EVENTS flag -off so that normal timers don't fire but modal ones do. -Second, if several modal timers have been created they stack: -only the top timer on the stack (the most recently created one) -is active at any point in time. -Modal timeouts must be deleted in inverse order from their creation. -Third, modal timeouts are not deleted when they fire: once a modal -timeout has fired, it will continue firing every time \fBTcl_DoOneEvent\fR -is called, until the timeout is deleted by calling -\fBTcl_DeleteModalTimeout\fR. -.PP -Modal timeouts are only needed in a few special situations, and they -should be used with caution. - -.SH KEYWORDS -callback, clock, handler, modal timeout diff --git a/contrib/tcl/doc/GetFile.3 b/contrib/tcl/doc/GetFile.3 deleted file mode 100644 index 68ffd219a8ac..000000000000 --- a/contrib/tcl/doc/GetFile.3 +++ /dev/null @@ -1,130 +0,0 @@ -'\" -'\" 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: @(#) GetFile.3 1.8 96/03/25 20:03:31 -'\" -.so man.macros -.TH Tcl_GetFile 3 7.5 Tcl "Tcl Library Procedures" -.BS -.SH NAME -Tcl_GetFile, Tcl_FreeFile, Tcl_GetFileInfo \- procedures to manipulate generic file handles -.SH SYNOPSIS -.nf -\fB#include <tcl.h>\fR -.sp -Tcl_File -\fBTcl_GetFile\fR(\fIosHandle, type\fR) -.sp -\fBTcl_FreeFile\fR(\fIhandle\fR) -.sp -ClientData -\fBTcl_GetFileInfo\fR(\fIhandle, typePtr\fR) -.sp -ClientData -\fBTcl_GetNotifierData\fR(\fIhandle, freeProcPtr\fR) -.sp -\fBTcl_SetNotifierData\fR(\fIhandle, freeProc, clientData\fR) -.SH ARGUMENTS -.AS Tcl_FileFreeProc **freeProcPtr -.AP ClientData osHandle in -Platform-specific file handle to be associated with the generic file handle. -.AP int type in -The type of platform-specific file handle associated with the generic file -handle. See below for a list of valid types. -.AP Tcl_File handle in -Generic file handle associated with platform-specific file information. -.AP int *typePtr in/out -If \fI*typePtr\fR is not NULL, then the specified word is set to -contain the type associated with \fIhandle\fR. -.AP Tcl_FileFreeProc *freeProc in -Procedure to call when \fIhandle\fR is deleted. -.AP Tcl_FileFreeProc **freeProcPtr in/out -Pointer to location in which to store address of current free procedure -for file handle. Ignored if NULL. -.AP ClientData clientData in -Arbitrary one-word value associated with the given file handle. This -data is owned by the caller. -.BE - -.SH DESCRIPTION -.PP -A \fBTcl_File\fR is an opaque handle used to refer to files in a -platform independent way in Tcl routines like -\fBTcl_CreateFileHandler\fR. A file handle has an associated -platform-dependent \fIosHandle\fR, a \fItype\fR and additional private -data used by the notifier to generate events for the file. The type -is an integer that determines how the platform-specific drivers will -interpret the \fIosHandle\fR. The types that are defined by the core -are: -.TP 22 -\fBTCL_UNIX_FD\fR -The \fIosHandle\fR is a Unix file descriptor. -.TP 22 -\fBTCL_MAC_FILE\fR -The file is a Macintosh file handle. -.TP 22 -\fBTCL_WIN_FILE\fR -The \fIosHandle\fR is a Windows normal file \fBHANDLE\fR. -.TP 22 -\fBTCL_WIN_PIPE\fR -The \fIosHandle\fR is a Windows anonymous pipe \fBHANDLE\fR. -.TP 22 -\fBTCL_WIN_SOCKET\fR -The \fIosHandle\fR is a Windows \fBSOCKET\fR. -.TP 22 -\fBTCL_WIN_CONSOLE\fR -The \fIosHandle\fR is a Windows console buffer \fBHANDLE\fR. -.PP -\fBTcl_GetFile\fR locates the file handle corresponding to a particular -\fIosHandle\fR and a \fItype\fR. If a file handle already existed for the -given file, then that handle will be returned. If this is the first time that -the file handle for a particular file is being retrieved, then a new file -handle will be allocated and returned. -.PP -When a file handle is no longer in use, it should be deallocated with -a call to \fBTcl_FreeFile\fR. A call to this function will invoke the -notifier free procedure \fIproc\fR, if there is one. After the -notifier has cleaned up, any resources used by the file handle will be -deallocated. \fBTcl_FreeFile\fR will not close the platform-specific -\fIosHandle\fR. -.PP -\fBTcl_GetFileInfo\fR may be used to retrieve the platform-specific -\fIosHandle\fR and type associated with a file handle. If -\fItypePtr\fR is not NULL, then the word at \fI*typePtr\fR is set to -the type of the file handle. The return value of the function is the -associated platform-specific \fIosHandle\fR. Note that this function -may be used to extract the platform-specific file handle from a -\fBTcl_File\fR so that it may be used in external interfaces. -However, programs written using this interface will be -platform-specific. -.PP -The \fBTcl_SetNotifierData\fR and \fBTcl_GetNotifierData\fR procedures are -intended to be used only by notifier writers. See the -\fITcl_CreateEventSource(3)\fR manual entry for more information on -the notifier. -.PP -\fBTcl_SetNotifierData\fR may be used by notifier writers to associate -notifier-specific information with a \fBTcl_File\fR. The \fIdata\fR -argument specifies a word that may be retrieved with a later call to -\fBTcl_GetNotifierData\fR. If the \fIfreeProc\fR argument is non-NULL -it specifies the address of a procedure to invoke when the -\fBTcl_File\fR is deleted. \fIfreeProc\fR should have arguments and -result that match the type \fBTcl_FileFreeProc\fR: -.CS -typedef void Tcl_FileFreeProc( - ClientData \fIclientData\fR); -.CE -When \fIfreeProc\fR is invoked the \fIclientData\fR argument will be -the same as the corresponding argument passed to -\fBTcl_SetNotifierData\fR. -.PP -\fBTcl_GetNotifierData\fR returns the \fIclientData\fR associated with -the given \fBTcl_File\fR, and if the \fIfreeProcPtr\fR field is -non-\fBNULL\fR, the address indicated by it gets the address of the -free procedure stored with this file. - -.SH KEYWORDS -generic file handle, file type, file descriptor, notifier diff --git a/contrib/tcl/generic/patchlevel.h b/contrib/tcl/generic/patchlevel.h deleted file mode 100644 index c755edec4901..000000000000 --- a/contrib/tcl/generic/patchlevel.h +++ /dev/null @@ -1,23 +0,0 @@ -/* - * 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.18 96/07/17 14:17:33 - */ - -#define TCL_PATCH_LEVEL "7.5p1" diff --git a/contrib/tcl/generic/tclExpr.c b/contrib/tcl/generic/tclExpr.c deleted file mode 100644 index 13d020fa49c2..000000000000 --- a/contrib/tcl/generic/tclExpr.c +++ /dev/null @@ -1,2055 +0,0 @@ -/* - * 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}, -}; - -/* - *-------------------------------------------------------------- - * - * 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(interp, string, valuePtr) - 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; - valuePtr->doubleValue = strtod(string, &term); - if ((term != string) && (*term == 0)) { - if (errno != 0) { - Tcl_ResetResult(interp); - TclExprFloatError(interp, valuePtr->doubleValue); - return TCL_ERROR; - } - valuePtr->type = TYPE_DOUBLE; - return TCL_OK; - } - } - } - - /* - * Not a valid number. Save a string value (but don't do anything - * if it's already the value). - */ - - valuePtr->type = TYPE_STRING; - if (string != valuePtr->pv.buffer) { - int length, shortfall; - - length = strlen(string); - valuePtr->pv.next = valuePtr->pv.buffer; - shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer); - if (shortfall > 0) { - (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); - } - strcpy(valuePtr->pv.buffer, string); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ExprLex -- - * - * Lexical analyzer for expression parser: parses a single value, - * operator, or other syntactic element from an expression string. - * - * Results: - * TCL_OK is returned unless an error occurred while doing lexical - * analysis or executing an embedded command. In that case a - * standard Tcl error is returned, using interp->result to hold - * an error message. In the event of a successful return, the token - * and field in infoPtr is updated to refer to the next symbol in - * the expression string, and the expr field is advanced past that - * token; if the token is a value, then the value is stored at - * valuePtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ExprLex(interp, infoPtr, valuePtr) - Tcl_Interp *interp; /* Interpreter to use for error - * reporting. */ - register ExprInfo *infoPtr; /* Describes the state of the parse. */ - register Value *valuePtr; /* Where to store value, if that is - * what's parsed from string. Caller - * must have initialized pv field - * correctly. */ -{ - register 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; - valuePtr->doubleValue = strtod(p, &term); - if (term != p) { - if (errno != 0) { - TclExprFloatError(interp, valuePtr->doubleValue); - return TCL_ERROR; - } - infoPtr->token = VALUE; - infoPtr->expr = term; - valuePtr->type = TYPE_DOUBLE; - return TCL_OK; - } - } - } - - infoPtr->expr = p+1; - switch (*p) { - case '$': - - /* - * Variable. Fetch its value, then see if it makes sense - * as an integer or floating-point number. - */ - - infoPtr->token = VALUE; - var = Tcl_ParseVar(interp, p, &infoPtr->expr); - if (var == NULL) { - return TCL_ERROR; - } - Tcl_ResetResult(interp); - if (((Interp *) interp)->noEval) { - valuePtr->type = TYPE_INT; - valuePtr->intValue = 0; - return TCL_OK; - } - return ExprParseString(interp, var, valuePtr); - - case '[': - infoPtr->token = VALUE; - ((Interp *) interp)->evalFlags = TCL_BRACKET_TERM; - result = Tcl_Eval(interp, p+1); - infoPtr->expr = ((Interp *) interp)->termPtr; - if (result != TCL_OK) { - return result; - } - infoPtr->expr++; - if (((Interp *) interp)->noEval) { - valuePtr->type = TYPE_INT; - valuePtr->intValue = 0; - Tcl_ResetResult(interp); - return TCL_OK; - } - result = ExprParseString(interp, interp->result, valuePtr); - if (result != TCL_OK) { - return result; - } - Tcl_ResetResult(interp); - return TCL_OK; - - case '"': - infoPtr->token = VALUE; - result = TclParseQuotes(interp, infoPtr->expr, '"', 0, - &infoPtr->expr, &valuePtr->pv); - if (result != TCL_OK) { - return result; - } - Tcl_ResetResult(interp); - return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); - - case '{': - infoPtr->token = VALUE; - result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr, - &valuePtr->pv); - if (result != TCL_OK) { - return result; - } - Tcl_ResetResult(interp); - return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); - - case '(': - infoPtr->token = OPEN_PAREN; - return TCL_OK; - - case ')': - infoPtr->token = CLOSE_PAREN; - return TCL_OK; - - case ',': - infoPtr->token = COMMA; - return TCL_OK; - - case '*': - infoPtr->token = MULT; - return TCL_OK; - - case '/': - infoPtr->token = DIVIDE; - return TCL_OK; - - case '%': - infoPtr->token = MOD; - return TCL_OK; - - case '+': - infoPtr->token = PLUS; - return TCL_OK; - - case '-': - infoPtr->token = MINUS; - return TCL_OK; - - case '?': - infoPtr->token = QUESTY; - return TCL_OK; - - case ':': - infoPtr->token = COLON; - return TCL_OK; - - case '<': - switch (p[1]) { - case '<': - infoPtr->expr = p+2; - infoPtr->token = LEFT_SHIFT; - break; - case '=': - infoPtr->expr = p+2; - infoPtr->token = LEQ; - break; - default: - infoPtr->token = LESS; - break; - } - return TCL_OK; - - case '>': - switch (p[1]) { - case '>': - infoPtr->expr = p+2; - infoPtr->token = RIGHT_SHIFT; - break; - case '=': - infoPtr->expr = p+2; - infoPtr->token = GEQ; - break; - default: - infoPtr->token = GREATER; - break; - } - return TCL_OK; - - case '=': - if (p[1] == '=') { - infoPtr->expr = p+2; - infoPtr->token = EQUAL; - } else { - infoPtr->token = UNKNOWN; - } - return TCL_OK; - - case '!': - if (p[1] == '=') { - infoPtr->expr = p+2; - infoPtr->token = NEQ; - } else { - infoPtr->token = NOT; - } - return TCL_OK; - - case '&': - if (p[1] == '&') { - infoPtr->expr = p+2; - infoPtr->token = AND; - } else { - infoPtr->token = BIT_AND; - } - return TCL_OK; - - case '^': - infoPtr->token = BIT_XOR; - return TCL_OK; - - case '|': - if (p[1] == '|') { - infoPtr->expr = p+2; - infoPtr->token = OR; - } else { - infoPtr->token = BIT_OR; - } - return TCL_OK; - - case '~': - infoPtr->token = BIT_NOT; - return TCL_OK; - - default: - if (isalpha(UCHAR(*p))) { - infoPtr->expr = p; - return ExprMathFunc(interp, infoPtr, valuePtr); - } - infoPtr->expr = p+1; - infoPtr->token = UNKNOWN; - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * ExprGetValue -- - * - * Parse a "value" from the remainder of the expression in infoPtr. - * - * Results: - * Normally TCL_OK is returned. The value of the expression is - * returned in *valuePtr. If an error occurred, then interp->result - * contains an error message and TCL_ERROR is returned. - * InfoPtr->token will be left pointing to the token AFTER the - * expression, and infoPtr->expr will point to the character just - * after the terminating token. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ExprGetValue(interp, infoPtr, prec, valuePtr) - Tcl_Interp *interp; /* Interpreter to use for error - * reporting. */ - register ExprInfo *infoPtr; /* Describes the state of the parse - * just before the value (i.e. ExprLex - * will be called to get first token - * of value). */ - int prec; /* Treat any un-parenthesized operator - * with precedence <= this as the end - * of the expression. */ - Value *valuePtr; /* Where to store the value of the - * expression. Caller must have - * initialized pv field. */ -{ - Interp *iPtr = (Interp *) interp; - Value value2; /* Second operand for current - * operator. */ - int operator; /* Current operator (either unary - * or binary). */ - int badType; /* Type of offending argument; used - * for error messages. */ - int gotOp; /* Non-zero means already lexed the - * operator (while picking up value - * for unary operator). Don't lex - * again. */ - int result; - - /* - * There are two phases to this procedure. First, pick off an initial - * value. Then, parse (binary operator, value) pairs until done. - */ - - gotOp = 0; - value2.pv.buffer = value2.pv.next = value2.staticSpace; - value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1; - value2.pv.expandProc = TclExpandParseValue; - value2.pv.clientData = (ClientData) NULL; - result = ExprLex(interp, infoPtr, valuePtr); - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token == OPEN_PAREN) { - - /* - * Parenthesized sub-expression. - */ - - result = ExprGetValue(interp, infoPtr, -1, valuePtr); - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token != CLOSE_PAREN) { - Tcl_AppendResult(interp, "unmatched parentheses in expression \"", - infoPtr->originalExpr, "\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - } else { - if (infoPtr->token == MINUS) { - infoPtr->token = UNARY_MINUS; - } - if (infoPtr->token == PLUS) { - infoPtr->token = UNARY_PLUS; - } - if (infoPtr->token >= UNARY_MINUS) { - - /* - * Process unary operators. - */ - - operator = infoPtr->token; - result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token], - valuePtr); - if (result != TCL_OK) { - goto done; - } - if (!iPtr->noEval) { - switch (operator) { - case UNARY_MINUS: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = -valuePtr->intValue; - } else if (valuePtr->type == TYPE_DOUBLE){ - valuePtr->doubleValue = -valuePtr->doubleValue; - } else { - badType = valuePtr->type; - goto illegalType; - } - break; - case UNARY_PLUS: - if ((valuePtr->type != TYPE_INT) - && (valuePtr->type != TYPE_DOUBLE)) { - badType = valuePtr->type; - goto illegalType; - } - break; - case NOT: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = !valuePtr->intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - /* - * Theoretically, should be able to use - * "!valuePtr->intValue", but apparently some - * compilers can't handle it. - */ - if (valuePtr->doubleValue == 0.0) { - valuePtr->intValue = 1; - } else { - valuePtr->intValue = 0; - } - valuePtr->type = TYPE_INT; - } else { - badType = valuePtr->type; - goto illegalType; - } - break; - case BIT_NOT: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = ~valuePtr->intValue; - } else { - badType = valuePtr->type; - goto illegalType; - } - break; - } - } - gotOp = 1; - } else if (infoPtr->token != VALUE) { - goto syntaxError; - } - } - - /* - * Got the first operand. Now fetch (operator, operand) pairs. - */ - - if (!gotOp) { - result = ExprLex(interp, infoPtr, &value2); - if (result != TCL_OK) { - goto done; - } - } - while (1) { - operator = infoPtr->token; - value2.pv.next = value2.pv.buffer; - if ((operator < MULT) || (operator >= UNARY_MINUS)) { - if ((operator == END) || (operator == CLOSE_PAREN) - || (operator == COMMA)) { - result = TCL_OK; - goto done; - } else { - goto syntaxError; - } - } - if (precTable[operator] <= prec) { - result = TCL_OK; - goto done; - } - - /* - * If we're doing an AND or OR and the first operand already - * determines the result, don't execute anything in the - * second operand: just parse. Same style for ?: pairs. - */ - - if ((operator == AND) || (operator == OR) || (operator == QUESTY)) { - if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = valuePtr->doubleValue != 0; - valuePtr->type = TYPE_INT; - } else if (valuePtr->type == TYPE_STRING) { - if (!iPtr->noEval) { - badType = TYPE_STRING; - goto illegalType; - } - - /* - * Must set valuePtr->intValue to avoid referencing - * uninitialized memory in the "if" below; the atual - * value doesn't matter, since it will be ignored. - */ - - valuePtr->intValue = 0; - } - if (((operator == AND) && !valuePtr->intValue) - || ((operator == OR) && valuePtr->intValue)) { - iPtr->noEval++; - result = ExprGetValue(interp, infoPtr, precTable[operator], - &value2); - iPtr->noEval--; - if (operator == OR) { - valuePtr->intValue = 1; - } - continue; - } else if (operator == QUESTY) { - /* - * Special note: ?: operators must associate right to - * left. To make this happen, use a precedence one lower - * than QUESTY when calling ExprGetValue recursively. - */ - - if (valuePtr->intValue != 0) { - valuePtr->pv.next = valuePtr->pv.buffer; - result = ExprGetValue(interp, infoPtr, - precTable[QUESTY] - 1, valuePtr); - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token != COLON) { - goto syntaxError; - } - value2.pv.next = value2.pv.buffer; - iPtr->noEval++; - result = ExprGetValue(interp, infoPtr, - precTable[QUESTY] - 1, &value2); - iPtr->noEval--; - } else { - iPtr->noEval++; - result = ExprGetValue(interp, infoPtr, - precTable[QUESTY] - 1, &value2); - iPtr->noEval--; - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token != COLON) { - goto syntaxError; - } - valuePtr->pv.next = valuePtr->pv.buffer; - result = ExprGetValue(interp, infoPtr, - precTable[QUESTY] - 1, valuePtr); - } - continue; - } else { - result = ExprGetValue(interp, infoPtr, precTable[operator], - &value2); - } - } else { - result = ExprGetValue(interp, infoPtr, precTable[operator], - &value2); - } - if (result != TCL_OK) { - goto done; - } - if ((infoPtr->token < MULT) && (infoPtr->token != VALUE) - && (infoPtr->token != END) && (infoPtr->token != COMMA) - && (infoPtr->token != CLOSE_PAREN)) { - goto syntaxError; - } - - if (iPtr->noEval) { - continue; - } - - /* - * At this point we've got two values and an operator. Check - * to make sure that the particular data types are appropriate - * for the particular operator, and perform type conversion - * if necessary. - */ - - switch (operator) { - - /* - * For the operators below, no strings are allowed and - * ints get converted to floats if necessary. - */ - - case MULT: case DIVIDE: case PLUS: case MINUS: - if ((valuePtr->type == TYPE_STRING) - || (value2.type == TYPE_STRING)) { - badType = TYPE_STRING; - goto illegalType; - } - if (valuePtr->type == TYPE_DOUBLE) { - if (value2.type == TYPE_INT) { - value2.doubleValue = value2.intValue; - value2.type = TYPE_DOUBLE; - } - } else if (value2.type == TYPE_DOUBLE) { - if (valuePtr->type == TYPE_INT) { - valuePtr->doubleValue = valuePtr->intValue; - valuePtr->type = TYPE_DOUBLE; - } - } - break; - - /* - * For the operators below, only integers are allowed. - */ - - case MOD: case LEFT_SHIFT: case RIGHT_SHIFT: - case BIT_AND: case BIT_XOR: case BIT_OR: - if (valuePtr->type != TYPE_INT) { - badType = valuePtr->type; - goto illegalType; - } else if (value2.type != TYPE_INT) { - badType = value2.type; - goto illegalType; - } - break; - - /* - * For the operators below, any type is allowed but the - * two operands must have the same type. Convert integers - * to floats and either to strings, if necessary. - */ - - case LESS: case GREATER: case LEQ: case GEQ: - case EQUAL: case NEQ: - if (valuePtr->type == TYPE_STRING) { - if (value2.type != TYPE_STRING) { - ExprMakeString(interp, &value2); - } - } else if (value2.type == TYPE_STRING) { - if (valuePtr->type != TYPE_STRING) { - ExprMakeString(interp, valuePtr); - } - } else if (valuePtr->type == TYPE_DOUBLE) { - if (value2.type == TYPE_INT) { - value2.doubleValue = value2.intValue; - value2.type = TYPE_DOUBLE; - } - } else if (value2.type == TYPE_DOUBLE) { - if (valuePtr->type == TYPE_INT) { - valuePtr->doubleValue = valuePtr->intValue; - valuePtr->type = TYPE_DOUBLE; - } - } - break; - - /* - * For the operators below, no strings are allowed, but - * no int->double conversions are performed. - */ - - case AND: case OR: - if (valuePtr->type == TYPE_STRING) { - badType = valuePtr->type; - goto illegalType; - } - if (value2.type == TYPE_STRING) { - badType = value2.type; - goto illegalType; - } - break; - - /* - * For the operators below, type and conversions are - * irrelevant: they're handled elsewhere. - */ - - case QUESTY: case COLON: - break; - - /* - * Any other operator is an error. - */ - - default: - interp->result = "unknown operator in expression"; - result = TCL_ERROR; - goto done; - } - - /* - * Carry out the function of the specified operator. - */ - - switch (operator) { - case MULT: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = valuePtr->intValue * value2.intValue; - } else { - valuePtr->doubleValue *= value2.doubleValue; - } - break; - case DIVIDE: - case MOD: - if (valuePtr->type == TYPE_INT) { - long divisor, quot, rem; - int negative; - - if (value2.intValue == 0) { - divideByZero: - interp->result = "divide by zero"; - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", - interp->result, (char *) NULL); - result = TCL_ERROR; - goto done; - } - - /* - * The code below is tricky because C doesn't guarantee - * much about the properties of the quotient or - * remainder, but Tcl does: the remainder always has - * the same sign as the divisor and a smaller absolute - * value. - */ - - divisor = value2.intValue; - negative = 0; - if (divisor < 0) { - divisor = -divisor; - valuePtr->intValue = -valuePtr->intValue; - negative = 1; - } - quot = valuePtr->intValue / divisor; - rem = valuePtr->intValue % divisor; - if (rem < 0) { - rem += divisor; - quot -= 1; - } - if (negative) { - rem = -rem; - } - valuePtr->intValue = (operator == DIVIDE) ? quot : rem; - } else { - if (value2.doubleValue == 0.0) { - goto divideByZero; - } - valuePtr->doubleValue /= value2.doubleValue; - } - break; - case PLUS: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = valuePtr->intValue + value2.intValue; - } else { - valuePtr->doubleValue += value2.doubleValue; - } - break; - case MINUS: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = valuePtr->intValue - value2.intValue; - } else { - valuePtr->doubleValue -= value2.doubleValue; - } - break; - case LEFT_SHIFT: - valuePtr->intValue <<= value2.intValue; - break; - case RIGHT_SHIFT: - /* - * The following code is a bit tricky: it ensures that - * right shifts propagate the sign bit even on machines - * where ">>" won't do it by default. - */ - - if (valuePtr->intValue < 0) { - valuePtr->intValue = - ~((~valuePtr->intValue) >> value2.intValue); - } else { - valuePtr->intValue >>= value2.intValue; - } - break; - case LESS: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue < value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue < value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0; - } - valuePtr->type = TYPE_INT; - break; - case GREATER: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue > value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue > value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0; - } - valuePtr->type = TYPE_INT; - break; - case LEQ: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue <= value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue <= value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0; - } - valuePtr->type = TYPE_INT; - break; - case GEQ: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue >= value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue >= value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0; - } - valuePtr->type = TYPE_INT; - break; - case EQUAL: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue == value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue == value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0; - } - valuePtr->type = TYPE_INT; - break; - case NEQ: - if (valuePtr->type == TYPE_INT) { - valuePtr->intValue = - valuePtr->intValue != value2.intValue; - } else if (valuePtr->type == TYPE_DOUBLE) { - valuePtr->intValue = - valuePtr->doubleValue != value2.doubleValue; - } else { - valuePtr->intValue = - strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0; - } - valuePtr->type = TYPE_INT; - break; - case BIT_AND: - valuePtr->intValue &= value2.intValue; - break; - case BIT_XOR: - valuePtr->intValue ^= value2.intValue; - break; - case BIT_OR: - valuePtr->intValue |= value2.intValue; - break; - - /* - * For AND and OR, we know that the first value has already - * been converted to an integer. Thus we need only consider - * the possibility of int vs. double for the second value. - */ - - case AND: - if (value2.type == TYPE_DOUBLE) { - value2.intValue = value2.doubleValue != 0; - value2.type = TYPE_INT; - } - valuePtr->intValue = valuePtr->intValue && value2.intValue; - break; - case OR: - if (value2.type == TYPE_DOUBLE) { - value2.intValue = value2.doubleValue != 0; - value2.type = TYPE_INT; - } - valuePtr->intValue = valuePtr->intValue || value2.intValue; - break; - - case COLON: - interp->result = "can't have : operator without ? first"; - result = TCL_ERROR; - goto done; - } - } - - done: - if (value2.pv.buffer != value2.staticSpace) { - ckfree(value2.pv.buffer); - } - return result; - - syntaxError: - Tcl_AppendResult(interp, "syntax error in expression \"", - infoPtr->originalExpr, "\"", (char *) NULL); - result = TCL_ERROR; - goto done; - - illegalType: - Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ? - "floating-point value" : "non-numeric string", - " as operand of \"", operatorStrings[operator], "\"", - (char *) NULL); - result = TCL_ERROR; - goto done; -} - -/* - *-------------------------------------------------------------- - * - * ExprMakeString -- - * - * Convert a value from int or double representation to - * a string. - * - * Results: - * The information at *valuePtr gets converted to string - * format, if it wasn't that way already. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -static void -ExprMakeString(interp, valuePtr) - Tcl_Interp *interp; /* Interpreter to use for precision - * information. */ - register Value *valuePtr; /* Value to be converted. */ -{ - int shortfall; - - shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer); - if (shortfall > 0) { - (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); - } - if (valuePtr->type == TYPE_INT) { - sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue); - } else if (valuePtr->type == TYPE_DOUBLE) { - Tcl_PrintDouble(interp, valuePtr->doubleValue, valuePtr->pv.buffer); - } - valuePtr->type = TYPE_STRING; -} - -/* - *-------------------------------------------------------------- - * - * ExprTopLevel -- - * - * This procedure provides top-level functionality shared by - * procedures like Tcl_ExprInt, Tcl_ExprDouble, etc. - * - * Results: - * The result is a standard Tcl return value. If an error - * occurs then an error message is left in interp->result. - * The value of the expression is returned in *valuePtr, in - * whatever form it ends up in (could be string or integer - * or double). Caller may need to convert result. Caller - * is also responsible for freeing string memory in *valuePtr, - * if any was allocated. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -static int -ExprTopLevel(interp, string, valuePtr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - char *string; /* Expression to evaluate. */ - Value *valuePtr; /* Where to store result. Should - * not be initialized by caller. */ -{ - ExprInfo info; - int result; - - /* - * Create the math functions the first time an expression is - * evaluated. - */ - - if (!(((Interp *) interp)->flags & EXPR_INITIALIZED)) { - BuiltinFunc *funcPtr; - - ((Interp *) interp)->flags |= EXPR_INITIALIZED; - for (funcPtr = funcTable; funcPtr->name != NULL; - funcPtr++) { - Tcl_CreateMathFunc(interp, funcPtr->name, funcPtr->numArgs, - funcPtr->argTypes, funcPtr->proc, funcPtr->clientData); - } - } - - info.originalExpr = string; - info.expr = string; - valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace; - valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1; - valuePtr->pv.expandProc = TclExpandParseValue; - valuePtr->pv.clientData = (ClientData) NULL; - - result = ExprGetValue(interp, &info, -1, valuePtr); - if (result != TCL_OK) { - return result; - } - if (info.token != END) { - Tcl_AppendResult(interp, "syntax error in expression \"", - string, "\"", (char *) NULL); - return TCL_ERROR; - } - if ((valuePtr->type == TYPE_DOUBLE) && (IS_NAN(valuePtr->doubleValue) - || IS_INF(valuePtr->doubleValue))) { - /* - * IEEE floating-point error. - */ - - TclExprFloatError(interp, valuePtr->doubleValue); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- - * - * Procedures to evaluate an expression and return its value - * in a particular form. - * - * Results: - * Each of the procedures below returns a standard Tcl result. - * If an error occurs then an error message is left in - * interp->result. Otherwise the value of the expression, - * in the appropriate form, is stored at *resultPtr. If - * the expression had a result that was incompatible with the - * desired form then an error is returned. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -int -Tcl_ExprLong(interp, string, ptr) - 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(interp, string, ptr) - 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(interp, string, ptr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - char *string; /* Expression to evaluate. */ - int *ptr; /* Where to store 0/1 result. */ -{ - Value value; - int result; - - result = ExprTopLevel(interp, string, &value); - if (result == TCL_OK) { - if (value.type == TYPE_INT) { - *ptr = value.intValue != 0; - } else if (value.type == TYPE_DOUBLE) { - *ptr = value.doubleValue != 0.0; - } else { - result = Tcl_GetBoolean(interp, value.pv.buffer, ptr); - } - } - if (value.pv.buffer != value.staticSpace) { - ckfree(value.pv.buffer); - } - return result; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_ExprString -- - * - * Evaluate an expression and return its value in string form. - * - * Results: - * A standard Tcl result. If the result is TCL_OK, then the - * interpreter's result is set to the string value of the - * expression. If the result is TCL_OK, then interp->result - * contains an error message. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -int -Tcl_ExprString(interp, string) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - char *string; /* Expression to evaluate. */ -{ - Value value; - int result; - - result = ExprTopLevel(interp, string, &value); - if (result == TCL_OK) { - if (value.type == TYPE_INT) { - sprintf(interp->result, "%ld", value.intValue); - } else if (value.type == TYPE_DOUBLE) { - Tcl_PrintDouble(interp, value.doubleValue, interp->result); - } else { - if (value.pv.buffer != value.staticSpace) { - interp->result = value.pv.buffer; - interp->freeProc = TCL_DYNAMIC; - value.pv.buffer = value.staticSpace; - } else { - Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE); - } - } - } - if (value.pv.buffer != value.staticSpace) { - ckfree(value.pv.buffer); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateMathFunc -- - * - * Creates a new math function for expressions in a given - * interpreter. - * - * Results: - * None. - * - * Side effects: - * The function defined by "name" is created; if such a function - * already existed then its definition is overriden. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which function is - * to be available. */ - char *name; /* Name of function (e.g. "sin"). */ - int numArgs; /* Nnumber of arguments required by - * function. */ - Tcl_ValueType *argTypes; /* Array of types acceptable for - * each argument. */ - Tcl_MathProc *proc; /* Procedure that implements the - * math function. */ - ClientData clientData; /* Additional value to pass to the - * function. */ -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int new, i; - - hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); - if (new) { - Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - if (numArgs > MAX_MATH_ARGS) { - numArgs = MAX_MATH_ARGS; - } - mathFuncPtr->numArgs = numArgs; - for (i = 0; i < numArgs; i++) { - mathFuncPtr->argTypes[i] = argTypes[i]; - } - mathFuncPtr->proc = proc; - mathFuncPtr->clientData = clientData; -} - -/* - *---------------------------------------------------------------------- - * - * ExprMathFunc -- - * - * This procedure is invoked to parse a math function from an - * expression string, carry out the function, and return the - * value computed. - * - * Results: - * TCL_OK is returned if all went well and the function's value - * was computed successfully. If an error occurred, TCL_ERROR - * is returned and an error message is left in interp->result. - * After a successful return infoPtr has been updated to refer - * to the character just after the function call, the token is - * set to VALUE, and the value is stored in valuePtr. - * - * Side effects: - * Embedded commands could have arbitrary side-effects. - * - *---------------------------------------------------------------------- - */ - -static int -ExprMathFunc(interp, infoPtr, valuePtr) - Tcl_Interp *interp; /* Interpreter to use for error - * reporting. */ - register ExprInfo *infoPtr; /* Describes the state of the parse. - * infoPtr->expr must point to the - * first character of the function's - * name. */ - register Value *valuePtr; /* Where to store value, if that is - * what's parsed from string. Caller - * must have initialized pv field - * correctly. */ -{ - Interp *iPtr = (Interp *) interp; - MathFunc *mathFuncPtr; /* Info about math function. */ - Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ - Tcl_Value funcResult; /* Result of function call. */ - Tcl_HashEntry *hPtr; - char *p, *funcName, savedChar; - int i, result; - - /* - * Find the end of the math function's name and lookup the MathFunc - * record for the function. - */ - - p = funcName = infoPtr->expr; - while (isalnum(UCHAR(*p)) || (*p == '_')) { - p++; - } - infoPtr->expr = p; - result = ExprLex(interp, infoPtr, valuePtr); - if (result != TCL_OK) { - return TCL_ERROR; - } - if (infoPtr->token != OPEN_PAREN) { - goto syntaxError; - } - savedChar = *p; - *p = 0; - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown math function \"", funcName, - "\"", (char *) NULL); - *p = savedChar; - return TCL_ERROR; - } - *p = savedChar; - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - - /* - * Scan off the arguments for the function, if there are any. - */ - - if (mathFuncPtr->numArgs == 0) { - result = ExprLex(interp, infoPtr, valuePtr); - if ((result != TCL_OK) || (infoPtr->token != CLOSE_PAREN)) { - goto syntaxError; - } - } else { - for (i = 0; ; i++) { - valuePtr->pv.next = valuePtr->pv.buffer; - result = ExprGetValue(interp, infoPtr, -1, valuePtr); - if (result != TCL_OK) { - return result; - } - if (valuePtr->type == TYPE_STRING) { - interp->result = - "argument to math function didn't have numeric value"; - return TCL_ERROR; - } - - /* - * Copy the value to the argument record, converting it if - * necessary. - */ - - if (valuePtr->type == TYPE_INT) { - if (mathFuncPtr->argTypes[i] == TCL_DOUBLE) { - args[i].type = TCL_DOUBLE; - args[i].doubleValue = valuePtr->intValue; - } else { - args[i].type = TCL_INT; - args[i].intValue = valuePtr->intValue; - } - } else { - if (mathFuncPtr->argTypes[i] == TCL_INT) { - args[i].type = TCL_INT; - args[i].intValue = (long) valuePtr->doubleValue; - } else { - args[i].type = TCL_DOUBLE; - args[i].doubleValue = valuePtr->doubleValue; - } - } - - /* - * Check for a comma separator between arguments or a close-paren - * to end the argument list. - */ - - if (i == (mathFuncPtr->numArgs-1)) { - if (infoPtr->token == CLOSE_PAREN) { - break; - } - if (infoPtr->token == COMMA) { - interp->result = "too many arguments for math function"; - return TCL_ERROR; - } else { - goto syntaxError; - } - } - if (infoPtr->token != COMMA) { - if (infoPtr->token == CLOSE_PAREN) { - interp->result = "too few arguments for math function"; - return TCL_ERROR; - } else { - goto syntaxError; - } - } - } - } - if (iPtr->noEval) { - valuePtr->type = TYPE_INT; - valuePtr->intValue = 0; - infoPtr->token = VALUE; - return TCL_OK; - } - - /* - * Invoke the function and copy its result back into valuePtr. - */ - - tcl_MathInProgress++; - result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, - &funcResult); - tcl_MathInProgress--; - if (result != TCL_OK) { - return result; - } - if (funcResult.type == TCL_INT) { - valuePtr->type = TYPE_INT; - valuePtr->intValue = funcResult.intValue; - } else { - valuePtr->type = TYPE_DOUBLE; - valuePtr->doubleValue = funcResult.doubleValue; - } - infoPtr->token = VALUE; - return TCL_OK; - - syntaxError: - Tcl_AppendResult(interp, "syntax error in expression \"", - infoPtr->originalExpr, "\"", (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclExprFloatError -- - * - * This procedure is called when an error occurs during a - * floating-point operation. It reads errno and sets - * interp->result accordingly. - * - * Results: - * Interp->result is set to hold an error message. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclExprFloatError(interp, value) - Tcl_Interp *interp; /* Where to store error message. */ - double value; /* Value returned after error; used to - * distinguish underflows from overflows. */ -{ - char buf[20]; - - if ((errno == EDOM) || (value != value)) { - interp->result = "domain error: argument not in valid range"; - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", interp->result, - (char *) NULL); - } else if ((errno == ERANGE) || IS_INF(value)) { - if (value == 0.0) { - interp->result = "floating-point value too small to represent"; - Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", interp->result, - (char *) NULL); - } else { - interp->result = "floating-point value too large to represent"; - Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", interp->result, - (char *) NULL); - } - } else { - sprintf(buf, "%d", errno); - Tcl_AppendResult(interp, "unknown floating-point error, ", - "errno = ", buf, (char *) NULL); - Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", interp->result, - (char *) NULL); - } -} - -/* - *---------------------------------------------------------------------- - * - * Math Functions -- - * - * This page contains the procedures that implement all of the - * built-in math functions for expressions. - * - * Results: - * Each procedure returns TCL_OK if it succeeds and places result - * information at *resultPtr. If it fails it returns TCL_ERROR - * and leaves an error message in interp->result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ExprUnaryFunc(clientData, interp, args, resultPtr) - 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, interp, args, resultPtr) - 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, interp, args, resultPtr) - 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, interp, args, resultPtr) - 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, interp, args, resultPtr) - 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, interp, args, resultPtr) - ClientData clientData; - Tcl_Interp *interp; - Tcl_Value *args; - Tcl_Value *resultPtr; -{ - resultPtr->type = TCL_INT; - if (args[0].type == TCL_INT) { - resultPtr->intValue = args[0].intValue; - } else { - if (args[0].doubleValue < 0) { - if (args[0].doubleValue <= (((double) (long) LONG_MIN) - 0.5)) { - tooLarge: - interp->result = "integer value too large to represent"; - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - interp->result, (char *) NULL); - return TCL_ERROR; - } - resultPtr->intValue = (long) (args[0].doubleValue - 0.5); - } else { - if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) { - goto tooLarge; - } - resultPtr->intValue = (long) (args[0].doubleValue + 0.5); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ExprLooksLikeInt -- - * - * This procedure decides whether the leading characters of a - * string look like an integer or something else (such as a - * floating-point number or string). - * - * Results: - * The return value is 1 if the leading characters of p look - * like a valid Tcl integer. If they look like a floating-point - * number (e.g. "e01" or "2.4"), or if they don't look like a - * number at all, then 0 is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ExprLooksLikeInt(p) - char *p; /* Pointer to string. */ -{ - while (isspace(UCHAR(*p))) { - p++; - } - if ((*p == '+') || (*p == '-')) { - p++; - } - if (!isdigit(UCHAR(*p))) { - return 0; - } - p++; - while (isdigit(UCHAR(*p))) { - p++; - } - if ((*p != '.') && (*p != 'e') && (*p != 'E')) { - return 1; - } - return 0; -} diff --git a/contrib/tcl/generic/tclFHandle.c b/contrib/tcl/generic/tclFHandle.c deleted file mode 100644 index f8b3798b3e70..000000000000 --- a/contrib/tcl/generic/tclFHandle.c +++ /dev/null @@ -1,259 +0,0 @@ -/* - * 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.8 96/06/27 15:31:34 - */ - -#include "tcl.h" -#include "tclInt.h" -#include "tclPort.h" - -/* - * The FileHashKey structure is used to associate the OS file handle and type - * with the corresponding notifier data in a FileHandle. - */ - -typedef struct FileHashKey { - int type; /* File handle type. */ - ClientData osHandle; /* Platform specific OS file handle. */ -} FileHashKey; - -typedef struct FileHandle { - FileHashKey key; /* Hash key for a given file. */ - ClientData data; /* Platform specific notifier data. */ - Tcl_FileFreeProc *proc; /* Callback to invoke when file is freed. */ -} FileHandle; - -/* - * Static variables used in this file: - */ - -static Tcl_HashTable fileTable; /* Hash table containing file handles. */ -static int initialized = 0; /* 1 if this module has been initialized. */ - -/* - * Static procedures used in this file: - */ - -static void FileExitProc _ANSI_ARGS_((ClientData clientData)); - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetFile -- - * - * This function retrieves the file handle associated with a - * platform specific file handle of the given type. It creates - * a new file handle if needed. - * - * Results: - * Returns the file handle associated with the file descriptor. - * - * Side effects: - * Initializes the file handle table if necessary. - * - *---------------------------------------------------------------------- - */ - -Tcl_File -Tcl_GetFile(osHandle, type) - ClientData osHandle; /* Platform specific file handle. */ - int type; /* Type of file handle. */ -{ - FileHashKey key; - Tcl_HashEntry *entryPtr; - int new; - - if (!initialized) { - Tcl_InitHashTable(&fileTable, sizeof(FileHashKey)/sizeof(int)); - Tcl_CreateExitHandler(FileExitProc, 0); - initialized = 1; - } - key.osHandle = osHandle; - key.type = type; - entryPtr = Tcl_CreateHashEntry(&fileTable, (char *) &key, &new); - if (new) { - FileHandle *newHandlePtr; - newHandlePtr = (FileHandle *) ckalloc(sizeof(FileHandle)); - newHandlePtr->key = key; - newHandlePtr->data = NULL; - newHandlePtr->proc = NULL; - Tcl_SetHashValue(entryPtr, newHandlePtr); - } - - return (Tcl_File) Tcl_GetHashValue(entryPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FreeFile -- - * - * Deallocates an entry in the file handle table. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FreeFile(handle) - Tcl_File handle; -{ - Tcl_HashEntry *entryPtr; - FileHandle *handlePtr = (FileHandle *) handle; - - /* - * Invoke free procedure, then delete the handle. - */ - - if (handlePtr->proc) { - (*handlePtr->proc)(handlePtr->data); - } - - /* - * Tcl_File structures may be freed as a result of running the - * channel table exit handler. The file table is freed by the file - * table exit handler, which may run before the channel table exit - * handler. The file table exit handler sets the "initialized" - * variable back to zero, so that the Tcl_FreeFile (when invoked - * from the channel table exit handler) can notice that the file - * table has already been destroyed. Otherwise, accessing a - * deleted hash table would cause a panic. - */ - - if (initialized) { - entryPtr = Tcl_FindHashEntry(&fileTable, (char *) &handlePtr->key); - if (entryPtr) { - Tcl_DeleteHashEntry(entryPtr); - } - } - ckfree((char *) handlePtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetFileInfo -- - * - * This function retrieves the platform specific file data and - * type from the file handle. - * - * Results: - * If typePtr is not NULL, sets *typePtr to the type of the file. - * Returns the platform specific file data. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_GetFileInfo(handle, typePtr) - Tcl_File handle; - int *typePtr; -{ - FileHandle *handlePtr = (FileHandle *) handle; - - if (typePtr) { - *typePtr = handlePtr->key.type; - } - return handlePtr->key.osHandle; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetNotifierData -- - * - * This function is used by the notifier to associate platform - * specific notifier information and a deletion procedure with - * a file handle. - * - * Results: - * None. - * - * Side effects: - * Updates the data and delProc slots in the file handle. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetNotifierData(handle, proc, data) - Tcl_File handle; - Tcl_FileFreeProc *proc; - ClientData data; -{ - FileHandle *handlePtr = (FileHandle *) handle; - handlePtr->proc = proc; - handlePtr->data = data; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetNotifierData -- - * - * This function is used by the notifier to retrieve the platform - * specific notifier information associated with a file handle. - * - * Results: - * Returns the data stored in a file handle by a previous call to - * Tcl_SetNotifierData, and places a pointer to the free proc - * in the location referred to by procPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_GetNotifierData(handle, procPtr) - Tcl_File handle; - Tcl_FileFreeProc **procPtr; -{ - FileHandle *handlePtr = (FileHandle *) handle; - if (procPtr != NULL) { - *procPtr = handlePtr->proc; - } - return handlePtr->data; -} - -/* - *---------------------------------------------------------------------- - * - * FileExitProc -- - * - * This function an exit handler that frees any memory allocated - * for the file handle table. - * - * Results: - * None. - * - * Side effects: - * Cleans up the file handle table. - * - *---------------------------------------------------------------------- - */ - -static void -FileExitProc(clientData) - ClientData clientData; /* Not used. */ -{ - Tcl_DeleteHashTable(&fileTable); - initialized = 0; -} diff --git a/contrib/tcl/library/safeinit.tcl b/contrib/tcl/library/safeinit.tcl deleted file mode 100644 index e1ce1a039599..000000000000 --- a/contrib/tcl/library/safeinit.tcl +++ /dev/null @@ -1,461 +0,0 @@ -# safeinit.tcl -- -# -# This code runs in a master to manage a safe slave with Safe Tcl. -# See the safe.n man page for details. -# -# Copyright (c) 1996-1997 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: @(#) safeinit.tcl 1.38 97/06/20 12:57:39 - -# This procedure creates a safe slave, initializes it with the -# safe base and installs the aliases for the security policy mechanism. - -proc tcl_safeCreateInterp {slave} { - global auto_path - - # Create the slave. - interp create -safe $slave - - # Set its auto_path - interp eval $slave [list set auto_path $auto_path] - - # And initialize it. - return [tcl_safeInitInterp $slave] -} - -# This procedure applies the initializations to an already existing -# interpreter. It is useful when you want to enable an interpreter -# created with "interp create -safe" to use security policies. - -proc tcl_safeInitInterp {slave} { - upvar #0 tclSafe$slave state - global tcl_library tk_library auto_path tcl_platform - - # These aliases let the slave load files to define new commands - - interp alias $slave source {} tclSafeAliasSource $slave - interp alias $slave load {} tclSafeAliasLoad $slave - - # This alias lets the slave have access to a subset of the 'file' - # command functionality. - tclAliasSubset $slave file file dir.* join root.* ext.* tail \ - path.* split - - # This alias interposes on the 'exit' command and cleanly terminates - # the slave. - interp alias $slave exit {} tcl_safeDeleteInterp $slave - - # Source init.tcl into the slave, to get auto_load and other - # procedures defined: - - if {$tcl_platform(platform) == "macintosh"} { - if {[catch {interp eval $slave [list source -rsrc Init]}]} { - if {[catch {interp eval $slave \ - [list source [file join $tcl_library init.tcl]]}]} { - error "can't source init.tcl into slave $slave" - } - } - } else { - if {[catch {interp eval $slave \ - [list source [file join $tcl_library init.tcl]]}]} { - error "can't source init.tcl into slave $slave" - } - } - - # Loading packages into slaves is handled by their master. - # This is overloaded to deal with regular packages and security policies - - interp alias $slave tclPkgUnknown {} tclSafeAliasPkgUnknown $slave - interp eval $slave {package unknown tclPkgUnknown} - - # We need a helper procedure to define a $dir variable and then - # do a source of the pkgIndex.tcl file - interp eval $slave \ - [list proc tclPkgSource {dir args} { - if {[llength $args] == 2} { - source [lindex $args 0] [lindex $args 1] - } else { - source [lindex $args 0] - } - }] - - # Let the slave inherit a few variables - foreach varName \ - {tcl_library tcl_version tcl_patchLevel \ - tcl_platform(platform) auto_path} { - upvar #0 $varName var - interp eval $slave [list set $varName $var] - } - - # Other variables are predefined with set values - foreach {varName value} { - auto_noexec 1 - errorCode {} - errorInfo {} - env() {} - argv0 {} - argv {} - argc 0 - tcl_interactive 0 - } { - interp eval $slave [list set $varName $value] - } - - # If auto_path is not set in the slave, set it to empty so it has - # a value and exists. Otherwise auto_loading and package require - # will complain. - - interp eval $slave { - if {![info exists auto_path]} { - set auto_path {} - } - } - - # If we have Tk, make the slave have the same library as us: - - if {[info exists tk_library]} { - interp eval $slave [list set tk_library $tk_library] - } - - # Stub out auto-exec mechanism in slave - interp eval $slave [list proc auto_execok {name} {return {}}] - - return $slave -} - -# This procedure deletes a safe slave managed by Safe Tcl and -# cleans up associated state: - -proc tcl_safeDeleteInterp {slave args} { - upvar #0 tclSafe$slave state - - # If the slave has a policy loaded, clean it up now. - if {[info exists state(policyLoaded)]} { - set policy $state(policyLoaded) - set proc ${policy}_PolicyCleanup - if {[string compare [info proc $proc] $proc] == 0} { - $proc $slave - } - } - - # Discard the global array of state associated with the slave, and - # delete the interpreter. - catch {unset state} - catch {interp delete $slave} - - return -} - -# This procedure computes the global security policy search path. - -proc tclSafeComputePolicyPath {} { - global auto_path tclSafeAutoPathComputed tclSafePolicyPath - - set recompute 0 - if {(![info exists tclSafePolicyPath]) || - ("$tclSafePolicyPath" == "")} { - set tclSafePolicyPath "" - set tclSafeAutoPathComputed "" - set recompute 1 - } - if {"$tclSafeAutoPathComputed" != "$auto_path"} { - set recompute 1 - set tclSafeAutoPathComputed $auto_path - } - if {$recompute == 1} { - set tclSafePolicyPath "" - foreach i $auto_path { - lappend tclSafePolicyPath [file join $i policies] - } - } - return $tclSafePolicyPath -} - -# --------------------------------------------------------------------------- -# --------------------------------------------------------------------------- - -# tclSafeAliasSource is the target of the "source" alias in safe interpreters. - -proc tclSafeAliasSource {slave args} { - global auto_path errorCode errorInfo - - if {[llength $args] == 2} { - if {[string compare "-rsrc" [lindex $args 0]] != 0} { - return -code error "incorrect arguments to source" - } - if {[catch {interp invokehidden $slave source -rsrc [lindex $args 1]} \ - msg]} { - return -code error $msg - } - } else { - set file [lindex $args 0] - if {[catch {tclFileInPath $file $auto_path $slave} msg]} { - return -code error "permission denied" - } - set errorInfo "" - if {[catch {interp invokehidden $slave source $file} msg]} { - return -code error $msg - } - } - return $msg -} - -# tclSafeAliasLoad is the target of the "load" alias in safe interpreters. - -proc tclSafeAliasLoad {slave file args} { - global auto_path - - if {[llength $args] == 2} { - # Trying to load into another interpreter - # Allow this for a child of the slave, or itself - set other [lindex $args 1] - foreach x $slave y $other { - if {[string length $x] == 0} { - break - } elseif {[string compare $x $y] != 0} { - return -code error "permission denied" - } - } - set slave $other - } - - if {[string length $file] && \ - [catch {tclFileInPath $file $auto_path $slave} msg]} { - return -code error "permission denied" - } - if {[catch { - switch [llength $args] { - 0 { - interp invokehidden $slave load $file - } - 1 - - 2 { - interp invokehidden $slave load $file [lindex $args 0] - } - default { - error "too many arguments to load" - } - } - } msg]} { - return -code error $msg - } - return $msg -} - -# tclFileInPath raises an error if the file is not found in -# the list of directories contained in path. - -proc tclFileInPath {file path slave} { - set realcheckpath [tclSafeCheckAutoPath $path $slave] - set pwd [pwd] - if {[file isdirectory $file]} { - error "$file: not found" - } - set parent [file dirname $file] - if {[catch {cd $parent} msg]} { - error "$file: not found" - } - set realfilepath [file split [pwd]] - foreach dir $realcheckpath { - set match 1 - foreach a [file split $dir] b $realfilepath { - if {[string length $a] == 0} { - break - } elseif {[string compare $a $b] != 0} { - set match 0 - break - } - } - if {$match} { - cd $pwd - return 1 - } - } - cd $pwd - error "$file: not found" -} - -# This procedure computes our expanded copy of the path, as needed. -# It returns the path after expanding out all aliases. - -proc tclSafeCheckAutoPath {path slave} { - global auto_path - upvar #0 tclSafe$slave state - - if {![info exists state(expanded_auto_path)]} { - # Compute for the first time: - set state(cached_auto_path) $path - } elseif {"$state(cached_auto_path)" != "$path"} { - # The value of our path changed, so recompute: - set state(cached_auto_path) $path - } else { - # No change: no need to recompute. - return $state(expanded_auto_path) - } - - set pwd [pwd] - set state(expanded_auto_path) "" - foreach dir $state(cached_auto_path) { - if {![catch {cd $dir}]} { - lappend state(expanded_auto_path) [pwd] - } - } - cd $pwd - return $state(expanded_auto_path) -} - -proc tclSafeAliasPkgUnknown {slave package version {exact {}}} { - tclSafeLoadPkg $slave $package $version $exact -} - -proc tclSafeLoadPkg {slave package version exact} { - if {[string length $version] == 0} { - set version 1.0 - } - tclSafeLoadPkgInternal $slave $package $version $exact 0 -} - -proc tclSafeLoadPkgInternal {slave package version exact round} { - global auto_path - upvar #0 tclSafe$slave state - - # Search the policy path again; it might have changed in the meantime. - - if {$round == 1} { - tclSafeResearchPolicyPath - - if {[tclSafeLoadPolicy $slave $package $version]} { - return - } - } - - # Try to load as a policy. - - if [tclSafeLoadPolicy $slave $package $version] { - return - } - - # The package is not a security policy, so do the regular setup. - - # Here we run tclPkgUnknown in the master, but we hijack - # the source command so the setup ends up happening in the slave. - - rename source source.orig - proc source {args} "upvar dir dir - interp eval [list $slave] tclPkgSource \[list \$dir\] \$args" - - if [catch {tclPkgUnknown $package $version $exact} err] { - global errorInfo - - rename source {} - rename source.orig source - - error "$err\n$errorInfo" - } - rename source {} - rename source.orig source - - # If we are in the first round, check if the package - # is now known in the slave: - - if {$round == 0} { - set ifneeded \ - [interp eval $slave [list package ifneeded $package $version]] - - if {"$ifneeded" == ""} { - return [tclSafeLoadPkgInternal $slave $package $version $exact 1] - } - } -} - -proc tclSafeResearchPolicyPath {} { - global tclSafePolicyPath auto_index auto_path - - # If there was no change, do not search again. - - if {![info exists tclSafePolicyPath]} { - set tclSafePolicyPath "" - } - set oldPolicyPath $tclSafePolicyPath - set newPolicyPath [tclSafeComputePolicyPath] - if {"$newPolicyPath" == "$oldPolicyPath"} { - return - } - - # Loop through the path from back to front so early directories - # end up overriding later directories. This code is like auto_load, - # but only new-style tclIndex files (version 2) are supported. - - for {set i [expr [llength $newPolicyPath] - 1]} \ - {$i >= 0} \ - {incr i -1} { - set dir [lindex $newPolicyPath $i] - set file [file join $dir tclIndex] - if {[file exists $file]} { - if {[catch {source $file} msg]} { - puts stderr "error sourcing $file: $msg" - } - } - foreach file [lsort [glob -nocomplain [file join $dir *]]] { - if {[file isdir $file]} { - set dir $file - set file [file join $file tclIndex] - if {[file exists $file]} { - if {[catch {source $file} msg]} { - puts stderr "error sourcing $file: $msg" - } - } - } - } - } -} - -proc tclSafeLoadPolicy {slave package version} { - upvar #0 tclSafe$slave state - global auto_index - - set proc ${package}_PolicyInit - - if {[info command $proc] == "$proc" || - [info exists auto_index($proc)]} { - if [info exists state(policyLoaded)] { - error "security policy $state(policyLoaded) already loaded" - } - $proc $slave $version - interp eval $slave [list package provide $package $version] - set state(policyLoaded) $package - return 1 - } else { - return 0 - } -} -# This procedure enables access from a safe interpreter to only a subset of -# the subcommands of a command: - -proc tclSafeSubset {command okpat args} { - set subcommand [lindex $args 0] - if {[regexp $okpat $subcommand]} { - return [eval {$command $subcommand} [lrange $args 1 end]] - } - error "not allowed to invoke subcommand $subcommand of $command" -} - -# This procedure installs an alias in a slave that invokes "safesubset" -# in the master to execute allowed subcommands. It precomputes the pattern -# of allowed subcommands; you can use wildcards in the pattern if you wish -# to allow subcommand abbreviation. -# -# Syntax is: tclAliasSubset slave alias target subcommand1 subcommand2... - -proc tclAliasSubset {slave alias target args} { - set pat ^(; set sep "" - foreach sub $args { - append pat $sep$sub - set sep | - } - append pat )\$ - interp alias $slave $alias {} tclSafeSubset $target $pat -} diff --git a/contrib/tcl/tests/fhandle.test b/contrib/tcl/tests/fhandle.test deleted file mode 100644 index 18fdb903978a..000000000000 --- a/contrib/tcl/tests/fhandle.test +++ /dev/null @@ -1,63 +0,0 @@ -# This file tests the functions in tclFHandle.c file. -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1995-1996 by 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: @(#) fhandle.test 1.3 96/03/26 11:49:04 - -if {[string compare test [info procs test]] == 1} then {source defs} - -if {[info commands testfhandle] == {}} { - puts "This application hasn't been compiled with the \"testfhandle\"" - puts "command, so I can't test the procedures in tclFHandle.c." - return -} - -test fhandle-1.1 {file handle creation/retrieval} { - testfhandle get 0 2 3 - testfhandle get 1 2 3 - set result [testfhandle compare 0 1] - testfhandle free 0 - set result -} {equal} -test fhandle-1.2 {file handle creation/retrieval} { - testfhandle get 0 2 3 - testfhandle get 1 2 4 - set result [testfhandle compare 0 1] - testfhandle free 0 - set result -} {notequal} -test fhandle-1.3 {file handle creation/retrieval} { - testfhandle get 0 2 3 - testfhandle get 1 2 4 - set result [testfhandle compare 0 1] - testfhandle free 0 - testfhandle free 1 - set result -} {notequal} -test fhandle-1.4 {file handle creation/retrieval} { - testfhandle get 0 2 3 - testfhandle get 1 5 3 - set result [testfhandle compare 0 1] - testfhandle free 0 - testfhandle free 1 - set result -} {notequal} -test fhandle-1.5 {file handle creation/retrieval} { - testfhandle get 0 5 6 - set result [testfhandle info2 0] - testfhandle free 0 - set result -} {5 6} -test fhandle-1.6 {file handle creation/retrieval} { - testfhandle get 0 5 6 - set result [testfhandle info1 0] - testfhandle free 0 - set result -} {5} diff --git a/contrib/tcl/tests/lsort.test b/contrib/tcl/tests/lsort.test deleted file mode 100644 index 907dfbf0c919..000000000000 --- a/contrib/tcl/tests/lsort.test +++ /dev/null @@ -1,126 +0,0 @@ -# Commands covered: lsort -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# 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: @(#) lsort.test 1.8 96/02/16 08:56:17 - -if {[string compare test [info procs test]] == 1} then {source defs} - -test lsort-1.1 {lsort command} { - lsort {abdeq ab 1 ac a} -} {1 a ab abdeq ac} -test lsort-1.2 {lsort command} { - lsort -decreasing {abdeq ab 1 ac a} -} {ac abdeq ab a 1} -test lsort-1.3 {lsort command} { - lsort -increasing {abdeq ab 1 ac a} -} {1 a ab abdeq ac} -test lsort-1.4 {lsort command} { - lsort {{one long element}} -} {{one long element}} -test lsort-1.5 {lsort command} { - lsort {} -} {} -test lsort-1.6 {lsort with characters needing backslashes} { - lsort {$ \\ [] \{} -} {{$} {[]} \\ \{} - -test lsort-2.1 {lsort -integer} { - lsort -integer -inc {1 180 62 040 180 -42 33 0x40} -} {-42 1 040 33 62 0x40 180 180} -test lsort-2.2 {lsort -integer} { - lsort -int -dec {1 180 62 040 180 -42 33 0x40} -} {180 180 0x40 62 33 040 1 -42} -test lsort-2.3 {lsort -integer} { - list [catch {lsort -integer {xxx 180.2 62 040 180 -42 33 0x40}} msg] $msg $errorInfo -} {1 {expected integer but got "xxx"} {expected integer but got "xxx" - (converting list element from string to integer) - invoked from within -"lsort -integer {xxx 180.2 62 040 180 -42 33 0x40}"}} -test lsort-2.4 {lsort -integer} { - list [catch {lsort -integer {1 180.2 62 040 180 -42 33 0x40}} msg] $msg $errorInfo -} {1 {expected integer but got "180.2"} {expected integer but got "180.2" - (converting list element from string to integer) - invoked from within -"lsort -integer {1 180.2 62 040 180 -42 33 0x40}"}} - -test lsort-3.1 {lsort -real} { - lsort -real {1 180.1 62 040 180 -42.7 33} -} {-42.7 1 33 040 62 180 180.1} -test lsort-3.2 {lsort -real} { - lsort -r -d {1 180.1 62 040 180 -42.7 33} -} {180.1 180 62 040 33 1 -42.7} -test lsort-3.3 {lsort -real} { - list [catch {lsort -real -inc {xxx 20 62 180 -42.7 33}} msg] $msg $errorInfo -} {1 {expected floating-point number but got "xxx"} {expected floating-point number but got "xxx" - (converting list element from string to real) - invoked from within -"lsort -real -inc {xxx 20 62 180 -42.7 33}"}} -test lsort-3.4 {lsort -real} { - list [catch {lsort -real -inc {1 0x40 62 180 -42.7 33}} msg] $msg $errorInfo -} {1 {expected floating-point number but got "0x40"} {expected floating-point number but got "0x40" - (converting list element from string to real) - invoked from within -"lsort -real -inc {1 0x40 62 180 -42.7 33}"}} - -proc lsort1 {a b} { - expr {2*([string match x* $a] - [string match x* $b]) - + [string match *y $a] - [string match *y $b]} -} -proc lsort2 {a b} { - error "comparison error" -} -proc lsort3 {a b} { - concat "foobar" -} - -test lsort-4.1 {lsort -command} { - lsort -command lsort1 {xxx yyy abc {xx y}} -} {abc yyy xxx {xx y}} -test lsort-4.2 {lsort -command} { - lsort -command lsort1 -dec {xxx yyy abc {xx y}} -} {{xx y} xxx yyy abc} -test lsort-4.3 {lsort -command} { - list [catch {lsort -command lsort2 -dec {1 1 1 1}} msg] $msg $errorInfo -} {1 {comparison error} {comparison error - while executing -"error "comparison error"" - (procedure "lsort2" line 2) - invoked from within -"lsort2 1 1" - (user-defined comparison command) - invoked from within -"lsort -command lsort2 -dec {1 1 1 1}"}} -test lsort-4.4 {lsort -command} { - list [catch {lsort -command lsort3 -dec {1 2 3 4}} msg] $msg $errorInfo -} {1 {comparison command returned non-numeric result} {comparison command returned non-numeric result - while executing -"lsort -command lsort3 -dec {1 2 3 4}"}} -test lsort-4.5 {lsort -command} { - list [catch {lsort -command {xxx yyy xxy abc}} msg] $msg -} {1 {"-command" must be followed by comparison command}} - -test lsort-5.1 {lsort errors} { - list [catch lsort msg] $msg -} {1 {wrong # args: should be "lsort ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing? ?-command string? list"}} -test lsort-5.2 {lsort errors} { - list [catch {lsort a b} msg] $msg -} {1 {bad switch "a": must be -ascii, -integer, -real, -increasing -decreasing, or -command}} -test lsort-5.3 {lsort errors} { - list [catch {lsort "\{"} msg] $msg -} {1 {unmatched open brace in list}} -test lsort-5.4 {lsort errors} { - list [catch {lsort -in {1 180.0 040 62 180 -42.7 33}} msg] $msg -} {1 {bad switch "-in": must be -ascii, -integer, -real, -increasing -decreasing, or -command}} -test lsort-5.5 {lsort errors: disallow recursion} { - proc x args {lsort {a b c}} - list [catch {lsort -command x {3 7}} msg] $msg -} {1 {can't invoke "lsort" recursively}} diff --git a/contrib/tcl/tests/policies/globalPolicy.tcl b/contrib/tcl/tests/policies/globalPolicy.tcl deleted file mode 100644 index 11904d4ffa5c..000000000000 --- a/contrib/tcl/tests/policies/globalPolicy.tcl +++ /dev/null @@ -1,4 +0,0 @@ -proc globalPolicy_PolicyInit {slave {version {}}} { - interp alias $slave tada {} tada $slave -} -proc tada {slave} {} diff --git a/contrib/tcl/tests/policies/packages/pkgA.tcl b/contrib/tcl/tests/policies/packages/pkgA.tcl deleted file mode 100644 index d54d2215c269..000000000000 --- a/contrib/tcl/tests/policies/packages/pkgA.tcl +++ /dev/null @@ -1,3 +0,0 @@ -package provide packageA 1.0 - -proc hoohum {} {return bazooka} diff --git a/contrib/tcl/tests/policies/packages/pkgIndex.tcl b/contrib/tcl/tests/policies/packages/pkgIndex.tcl deleted file mode 100644 index 5d39a66ef355..000000000000 --- a/contrib/tcl/tests/policies/packages/pkgIndex.tcl +++ /dev/null @@ -1,11 +0,0 @@ -# Tcl package index file, version 1.0 -# This file is generated by the "pkg_mkIndex" command -# and sourced either when an application starts up or -# by a "package unknown" script. It invokes the -# "package ifneeded" command to set up package-related -# information so that packages will be loaded automatically -# in response to "package require" commands. When this -# script is sourced, the variable $dir must contain the -# full path name of this file's directory. - -package ifneeded packageA 1.0 [list tclPkgSetup $dir packageA 1.0 {{pkgA.tcl source hoohum}}] diff --git a/contrib/tcl/tests/policies/policyA/policy.tcl b/contrib/tcl/tests/policies/policyA/policy.tcl deleted file mode 100644 index cfd558f4160d..000000000000 --- a/contrib/tcl/tests/policies/policyA/policy.tcl +++ /dev/null @@ -1,5 +0,0 @@ -proc policyA_PolicyInit {slave {version {}}} { - interp alias $slave tada {} tada $slave -} -proc tada {slave} {} - diff --git a/contrib/tcl/tests/policies/policyA/tclIndex b/contrib/tcl/tests/policies/policyA/tclIndex deleted file mode 100644 index 5a555373249e..000000000000 --- a/contrib/tcl/tests/policies/policyA/tclIndex +++ /dev/null @@ -1,9 +0,0 @@ -# Tcl autoload index file, version 2.0 -# This file is generated by the "auto_mkindex" command -# and sourced to set up indexing information for one or -# more commands. Typically each line is a command that -# sets an element in the auto_index array, where the -# element name is the name of a command and the value is -# a script that loads the command. - -set auto_index(policyA_PolicyInit) [list source [file join $dir policy.tcl]] diff --git a/contrib/tcl/tests/policies/policyB/policy.tcl b/contrib/tcl/tests/policies/policyB/policy.tcl deleted file mode 100644 index 51ceff7186f5..000000000000 --- a/contrib/tcl/tests/policies/policyB/policy.tcl +++ /dev/null @@ -1,2 +0,0 @@ -proc policyB_PolicyInit {slave {version 1.0}} { -} diff --git a/contrib/tcl/tests/policies/policyB/tclIndex b/contrib/tcl/tests/policies/policyB/tclIndex deleted file mode 100644 index 8abf6d11d749..000000000000 --- a/contrib/tcl/tests/policies/policyB/tclIndex +++ /dev/null @@ -1,9 +0,0 @@ -# Tcl autoload index file, version 2.0 -# This file is generated by the "auto_mkindex" command -# and sourced to set up indexing information for one or -# more commands. Typically each line is a command that -# sets an element in the auto_index array, where the -# element name is the name of a command and the value is -# a script that loads the command. - -set auto_index(policyB_PolicyInit) [list source [file join $dir policy.tcl]] diff --git a/contrib/tcl/tests/policies/policyC/policy.tcl b/contrib/tcl/tests/policies/policyC/policy.tcl deleted file mode 100644 index 2615b316bbb6..000000000000 --- a/contrib/tcl/tests/policies/policyC/policy.tcl +++ /dev/null @@ -1,7 +0,0 @@ -proc policyC_PolicyInit {slave {version 1.0}} { -} -proc policyC_PolicyCleanup {slave} { - global l - - lappend l bye -} diff --git a/contrib/tcl/tests/policies/policyC/tclIndex b/contrib/tcl/tests/policies/policyC/tclIndex deleted file mode 100644 index d56e723a9969..000000000000 --- a/contrib/tcl/tests/policies/policyC/tclIndex +++ /dev/null @@ -1,10 +0,0 @@ -# Tcl autoload index file, version 2.0 -# This file is generated by the "auto_mkindex" command -# and sourced to set up indexing information for one or -# more commands. Typically each line is a command that -# sets an element in the auto_index array, where the -# element name is the name of a command and the value is -# a script that loads the command. - -set auto_index(policyC_PolicyInit) [list source [file join $dir policy.tcl]] -set auto_index(policyC_PolicyCleanup) [list source [file join $dir policy.tcl]] diff --git a/contrib/tcl/tests/policies/tclIndex b/contrib/tcl/tests/policies/tclIndex deleted file mode 100644 index ce2fa7f02751..000000000000 --- a/contrib/tcl/tests/policies/tclIndex +++ /dev/null @@ -1,10 +0,0 @@ -# Tcl autoload index file, version 2.0 -# This file is generated by the "auto_mkindex" command -# and sourced to set up indexing information for one or -# more commands. Typically each line is a command that -# sets an element in the auto_index array, where the -# element name is the name of a command and the value is -# a script that loads the command. - -set auto_index(globalPolicy_PolicyInit) [list source [file join $dir globalPolicy.tcl]] -set auto_index(tada) [list source [file join $dir globalPolicy.tcl]] diff --git a/contrib/tcl/unix/bp.c b/contrib/tcl/unix/bp.c deleted file mode 100644 index b8c7a49b2f43..000000000000 --- a/contrib/tcl/unix/bp.c +++ /dev/null @@ -1,127 +0,0 @@ -/* - * bp.c -- - * - * This file contains the "bp" ("binary patch") program. It is used - * to replace configuration strings in Tcl/Tk binaries as part of - * installation. - * - * Usage: bp file search replace - * - * This program searches file bp for the first occurrence of the - * character string given by "search". If it is found, then the - * first characters of that string get replaced by the string - * given by "replace". The replacement string is NULL-terminated. - * - * Copyright (c) 1996 Sun Microsystems, Inc. - * All rights reserved. - * This file is NOT subject to the terms described in "license.terms". - * - * SCCS: @(#) bp.c 1.2 96/03/12 09:08:26 - */ - -#include <stdio.h> -#include <string.h> - -extern int errno; - -/* - * The array below saves the last few bytes read from the file, so that - * they can be compared against a particular string that we're looking - * for. - */ - -#define BUFFER_SIZE 200 -char buffer[BUFFER_SIZE]; - -int -main(argc, argv) - int argc; /* Number of command-line arguments. */ - char **argv; /* Values of command-line arguments. */ -{ - int length, matchChar, fileChar, cur, fileIndex, stringIndex; - char *s; - FILE *f; - - if (argc != 4) { - fprintf(stderr, - "Wrong # args: should be \"%s fileName string replace\"\n", - argv[0]); - exit(1); - } - f = fopen(argv[1], "r+"); - if (f == NULL) { - fprintf(stderr, - "Couldn't open \"%s\" for writing: %s\n", - argv[1], strerror(errno)); - exit(1); - } - - for (cur = 0; cur < BUFFER_SIZE; cur++) { - buffer[cur] = 0; - } - s = argv[2]; - length = strlen(s); - if (length > BUFFER_SIZE) { - fprintf(stderr, - "String \"%s\" too long; must be %d or fewer chars.\n", - s, BUFFER_SIZE); - exit(1); - } - matchChar = s[length-1]; - - while (1) { - fileChar = getc(f); - if (fileChar == EOF) { - if (ferror(f)) { - goto ioError; - } - fprintf(stderr, "Couldn't find string \"%s\"\n", argv[2]); - exit(1); - } - buffer[cur] = fileChar; - if (fileChar == matchChar) { - /* - * Last character of the string matches the current character - * from the file. Search backwards through the buffer to - * see if the preceding characters from the file match the - * characters from the string. - */ - for (fileIndex = cur-1, stringIndex = length-2; - stringIndex >= 0; fileIndex--, stringIndex--) { - if (fileIndex < 0) { - fileIndex = BUFFER_SIZE-1; - } - if (buffer[fileIndex] != s[stringIndex]) { - goto noMatch; - } - } - - /* - * Matched! Backup to the start of the string, then - * overwrite it with the replacement value. - */ - - if (fseek(f, -length, SEEK_CUR) == -1) { - goto ioError; - } - if (fwrite(argv[3], strlen(argv[3])+1, 1, f) == 0) { - goto ioError; - } - exit(0); - } - - /* - * No match; go on to next character of file. - */ - - noMatch: - cur++; - if (cur >= BUFFER_SIZE) { - cur = 0; - } - } - - ioError: - fprintf(stderr, "I/O error: %s\n", strerror(errno)); - exit(1); -} diff --git a/contrib/tcl/unix/tclLoadDl2.c b/contrib/tcl/unix/tclLoadDl2.c deleted file mode 100644 index ad18537f1440..000000000000 --- a/contrib/tcl/unix/tclLoadDl2.c +++ /dev/null @@ -1,113 +0,0 @@ -/* - * tclLoadDl2.c -- - * - * This procedure provides a version of the TclLoadFile that - * works with the "dlopen" and "dlsym" library procedures for - * dynamic loading. It is identical to tclLoadDl.c except that - * it adds a "_" character to symbol names before looking them - * up. - * - * 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: @(#) tclLoadDl2.c 1.3 96/02/15 11:58:45 - */ - -#include "tcl.h" -#include "dlfcn.h" - -/* - * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined - * and this argument to dlopen must always be 1. - */ - -#ifndef RTLD_NOW -# define RTLD_NOW 1 -#endif - -/* - *---------------------------------------------------------------------- - * - * TclLoadFile -- - * - * Dynamically loads a binary code file into memory and returns - * the addresses of two procedures within that file, if they - * are defined. - * - * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in interp->result. *proc1Ptr and *proc2Ptr - * are filled in with the addresses of the symbols given by - * *sym1 and *sym2, or NULL if those symbols can't be found. - * - * Side effects: - * New code suddenly appears in memory. - * - *---------------------------------------------------------------------- - */ - -int -TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *fileName; /* Name of the file containing the desired - * code. */ - char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; - /* Where to return the addresses corresponding - * to sym1 and sym2. */ -{ - VOID *handle; - Tcl_DString newName; - - handle = dlopen(fileName, RTLD_NOW); - if (handle == NULL) { - Tcl_AppendResult(interp, "couldn't load file \"", fileName, - "\": ", dlerror(), (char *) NULL); - return TCL_ERROR; - } - Tcl_DStringInit(&newName); - Tcl_DStringAppend(&newName, "_", 1); - Tcl_DStringAppend(&newName, sym1, -1); - *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, - Tcl_DStringValue(&newName)); - Tcl_DStringSetLength(&newName, 0); - Tcl_DStringAppend(&newName, "_", 1); - Tcl_DStringAppend(&newName, sym2, -1); - *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, - Tcl_DStringValue(&newName)); - Tcl_DStringFree(&newName); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclGuessPackageName -- - * - * If the "load" command is invoked without providing a package - * name, this procedure is invoked to try to figure it out. - * - * Results: - * Always returns 0 to indicate that we couldn't figure out a - * package name; generic code will then try to guess the package - * from the file name. A return value of 1 would have meant that - * we figured out the package name and put it in bufPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGuessPackageName(fileName, bufPtr) - char *fileName; /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr; /* Initialized empty dstring. Append - * package name to this if possible. */ -{ - return 0; -} |