diff options
Diffstat (limited to 'tcl/generic')
57 files changed, 84520 insertions, 0 deletions
diff --git a/tcl/generic/README b/tcl/generic/README new file mode 100644 index 00000000000..b7d94230b29 --- /dev/null +++ b/tcl/generic/README @@ -0,0 +1,5 @@ +This directory contains Tcl source files that work on all the platforms +where Tcl runs (e.g. UNIX, PCs, and Macintoshes). Platform-specific +sources are in the directories ../unix, ../win, and ../mac. + +RCS: @(#) $Id$ diff --git a/tcl/generic/tcl.h b/tcl/generic/tcl.h new file mode 100644 index 00000000000..c0569829f8b --- /dev/null +++ b/tcl/generic/tcl.h @@ -0,0 +1,1567 @@ +/* + * tcl.h -- + * + * This header file describes the externally-visible facilities + * of the Tcl interpreter. + * + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1993-1996 Lucent Technologies. + * Copyright (c) 1998 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#ifndef _TCL +#define _TCL + +/* + * When version numbers change here, must also go into the following files + * and update the version numbers: + * + * README + * library/init.tcl (only if major.minor changes, not patchlevel) + * unix/configure.in + * win/makefile.bc (only if major.minor changes, not patchlevel) + * win/makefile.vc (only if major.minor changes, not patchlevel) + * win/README + * win/README.binary + * + * The release level should be 0 for alpha, 1 for beta, and 2 for + * final/patch. The release serial value is the number that follows the + * "a", "b", or "p" in the patch level; for example, if the patch level + * is 7.6b2, TCL_RELEASE_SERIAL is 2. It restarts at 1 whenever the + * release level is changed, except for the final release which is 0 + * (the first patch will start at 1). + */ + +#define TCL_MAJOR_VERSION 8 +#define TCL_MINOR_VERSION 0 +#define TCL_RELEASE_LEVEL 2 +#define TCL_RELEASE_SERIAL 4 + +#define TCL_VERSION "8.0" +#define TCL_PATCH_LEVEL "8.0.4" + +/* + * The following definitions set up the proper options for Windows + * compilers. We use this method because there is no autoconf equivalent. + */ + +#ifndef __WIN32__ +# if defined(_WIN32) || defined(WIN32) +# define __WIN32__ +# endif +#endif + +#ifdef __WIN32__ +# ifndef STRICT +# define STRICT +# endif +# ifndef USE_PROTOTYPE +# define USE_PROTOTYPE 1 +# endif +# ifndef HAS_STDARG +# define HAS_STDARG 1 +# endif +# ifndef USE_PROTOTYPE +# define USE_PROTOTYPE 1 +# endif +# ifndef USE_TCLALLOC +# define USE_TCLALLOC 1 +# endif +#endif /* __WIN32__ */ + +/* + * The following definitions set up the proper options for Macintosh + * compilers. We use this method because there is no autoconf equivalent. + */ + +#ifdef MAC_TCL +# ifndef HAS_STDARG +# define HAS_STDARG 1 +# endif +# ifndef USE_TCLALLOC +# define USE_TCLALLOC 1 +# endif +# ifndef NO_STRERROR +# define NO_STRERROR 1 +# endif +#endif + +/* + * Utility macros: STRINGIFY takes an argument and wraps it in "" (double + * quotation marks), JOIN joins two arguments. + */ + +#define VERBATIM(x) x +#ifdef _MSC_VER +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +# define JOIN(a,b) JOIN1(a,b) +# define JOIN1(a,b) a##b +#else +# ifdef RESOURCE_INCLUDED +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +# define JOIN(a,b) JOIN1(a,b) +# define JOIN1(a,b) a##b +# else +# ifdef __STDC__ +# define STRINGIFY(x) #x +# define JOIN(a,b) a##b +# else +# define STRINGIFY(x) "x" +# define JOIN(a,b) VERBATIM(a)VERBATIM(b) +# endif +# endif +#endif + +/* + * A special definition used to allow this header file to be included + * in resource files so that they can get obtain version information from + * this file. Resource compilers don't like all the C stuff, like typedefs + * and procedure declarations, that occur below. + */ + +#ifndef RESOURCE_INCLUDED + +#ifndef BUFSIZ +#include <stdio.h> +#endif + +/* + * Definitions that allow Tcl functions with variable numbers of + * arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS + * is used in procedure prototypes. TCL_VARARGS_DEF is used to declare + * the arguments in a function definiton: it takes the type and name of + * the first argument and supplies the appropriate argument declaration + * string for use in the function definition. TCL_VARARGS_START + * initializes the va_list data structure and returns the first argument. + */ + +#if defined(__STDC__) || defined(HAS_STDARG) +# define TCL_VARARGS(type, name) (type name, ...) +# define TCL_VARARGS_DEF(type, name) (type name, ...) +# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) +#else +# ifdef __cplusplus +# define TCL_VARARGS(type, name) (type name, ...) +# define TCL_VARARGS_DEF(type, name) (type va_alist, ...) +# else +# define TCL_VARARGS(type, name) () +# define TCL_VARARGS_DEF(type, name) (va_alist) +# endif +# define TCL_VARARGS_START(type, name, list) \ + (va_start(list), va_arg(list, type)) +#endif + +/* + * Macros used to declare a function to be exported by a DLL. + * Used by Windows, maps to no-op declarations on non-Windows systems. + * The default build on windows is for a DLL, which causes the DLLIMPORT + * and DLLEXPORT macros to be nonempty. To build a static library, the + * macro STATIC_BUILD should be defined. + * The support follows the convention that a macro called BUILD_xxxx, where + * xxxx is the name of a library we are building, is set on the compile line + * for sources that are to be placed in the library. See BUILD_tcl in this + * file for an example of how the macro is to be used. + */ + +#ifdef __WIN32__ +# ifdef STATIC_BUILD +# define DLLIMPORT +# define DLLEXPORT +# else +# ifdef _MSC_VER +# define DLLIMPORT __declspec(dllimport) +# define DLLEXPORT __declspec(dllexport) +# else +# define DLLIMPORT +# define DLLEXPORT +# endif +# endif +#else +# define DLLIMPORT +# define DLLEXPORT +#endif + +#ifdef TCL_STORAGE_CLASS +# undef TCL_STORAGE_CLASS +#endif +#ifdef BUILD_tcl +# define TCL_STORAGE_CLASS DLLEXPORT +#else +# define TCL_STORAGE_CLASS DLLIMPORT +#endif + +/* + * Definitions that allow this header file to be used either with or + * without ANSI C features like function prototypes. + */ + +#undef _ANSI_ARGS_ +#undef CONST + +#if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) || defined(USE_PROTOTYPE) +# define _USING_PROTOTYPES_ 1 +# define _ANSI_ARGS_(x) x +# define CONST const +#else +# define _ANSI_ARGS_(x) () +# define CONST +#endif + +#ifdef __cplusplus +# define EXTERN extern "C" TCL_STORAGE_CLASS +#else +# define EXTERN extern TCL_STORAGE_CLASS +#endif + +/* + * Macro to use instead of "void" for arguments that must have + * type "void *" in ANSI C; maps them to type "char *" in + * non-ANSI systems. + */ +#ifndef __WIN32__ +#ifndef VOID +# ifdef __STDC__ +# define VOID void +# else +# define VOID char +# endif +#endif +#else /* __WIN32__ */ +/* + * The following code is copied from winnt.h + */ +#ifndef VOID +#define VOID void +typedef char CHAR; +typedef short SHORT; +typedef long LONG; +#endif +#endif /* __WIN32__ */ + +/* + * Miscellaneous declarations. + */ + +#ifndef NULL +#define NULL 0 +#endif + +#ifndef _CLIENTDATA +# if defined(__STDC__) || defined(__cplusplus) + typedef void *ClientData; +# else + typedef int *ClientData; +# endif /* __STDC__ */ +#define _CLIENTDATA +#endif + +/* + * Data structures defined opaquely in this module. The definitions below + * just provide dummy types. A few fields are made visible in Tcl_Interp + * structures, namely those used for returning a string result from + * commands. Direct access to the result field is discouraged in Tcl 8.0. + * The interpreter result is either an object or a string, and the two + * values are kept consistent unless some C code sets interp->result + * directly. Programmers should use either the procedure Tcl_GetObjResult() + * or Tcl_GetStringResult() to read the interpreter's result. See the + * SetResult man page for details. + * + * Note: any change to the Tcl_Interp definition below must be mirrored + * in the "real" definition in tclInt.h. + * + * Note: Tcl_ObjCmdProc procedures do not directly set result and freeProc. + * Instead, they set a Tcl_Obj member in the "real" structure that can be + * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). + */ + +typedef struct Tcl_Interp { + char *result; /* If the last command returned a string + * result, this points to it. */ + void (*freeProc) _ANSI_ARGS_((char *blockPtr)); + /* Zero means the string result is + * statically allocated. TCL_DYNAMIC means + * it was allocated with ckalloc and should + * be freed with ckfree. Other values give + * the address of procedure to invoke to + * free the result. Tcl_Eval must free it + * before executing next command. */ + int errorLine; /* When TCL_ERROR is returned, this gives + * the line number within the command where + * the error occurred (1 if first line). */ +} Tcl_Interp; + +typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; +typedef struct Tcl_Channel_ *Tcl_Channel; +typedef struct Tcl_Command_ *Tcl_Command; +typedef struct Tcl_Event Tcl_Event; +typedef struct Tcl_Pid_ *Tcl_Pid; +typedef struct Tcl_RegExp_ *Tcl_RegExp; +typedef struct Tcl_TimerToken_ *Tcl_TimerToken; +typedef struct Tcl_Trace_ *Tcl_Trace; +typedef struct Tcl_Var_ *Tcl_Var; + +/* + * When a TCL command returns, the interpreter contains a result from the + * command. Programmers are strongly encouraged to use one of the + * procedures Tcl_GetObjResult() or Tcl_GetStringResult() to read the + * interpreter's result. See the SetResult man page for details. Besides + * this result, the command procedure returns an integer code, which is + * one of the following: + * + * TCL_OK Command completed normally; the interpreter's + * result contains the command's result. + * TCL_ERROR The command couldn't be completed successfully; + * the interpreter's result describes what went wrong. + * TCL_RETURN The command requests that the current procedure + * return; the interpreter's result contains the + * procedure's return value. + * TCL_BREAK The command requests that the innermost loop + * be exited; the interpreter's result is meaningless. + * TCL_CONTINUE Go on to the next iteration of the current loop; + * the interpreter's result is meaningless. + */ + +#define TCL_OK 0 +#define TCL_ERROR 1 +#define TCL_RETURN 2 +#define TCL_BREAK 3 +#define TCL_CONTINUE 4 + +#define TCL_RESULT_SIZE 200 + +/* + * Argument descriptors for math function callbacks in expressions: + */ + +typedef enum {TCL_INT, TCL_DOUBLE, TCL_EITHER} Tcl_ValueType; +typedef struct Tcl_Value { + Tcl_ValueType type; /* Indicates intValue or doubleValue is + * valid, or both. */ + long intValue; /* Integer value. */ + double doubleValue; /* Double-precision floating value. */ +} Tcl_Value; + +/* + * Forward declaration of Tcl_Obj to prevent an error when the forward + * reference to Tcl_Obj is encountered in the procedure types declared + * below. + */ + +struct Tcl_Obj; + +/* + * Procedure types defined by Tcl: + */ + +typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask)); +typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data)); +typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData)); +typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); +typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, + ClientData cmdClientData, int argc, char *argv[])); +typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, + struct Tcl_Obj *dupPtr)); +typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); +typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData, + int flags)); +typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr, + ClientData clientData)); +typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData, + int flags)); +typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask)); +typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_FreeInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); +typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr)); +typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); +typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData)); +typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[])); +typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, + Tcl_Channel chan, char *address, int port)); +typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData)); +typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp, + struct Tcl_Obj *objPtr)); +typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); +typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *part1, char *part2, int flags)); + +/* + * The following structure represents a type of object, which is a + * particular internal representation for an object plus a set of + * procedures that provide standard operations on objects of that type. + */ + +typedef struct Tcl_ObjType { + char *name; /* Name of the type, e.g. "int". */ + Tcl_FreeInternalRepProc *freeIntRepProc; + /* Called to free any storage for the type's + * internal rep. NULL if the internal rep + * does not need freeing. */ + Tcl_DupInternalRepProc *dupIntRepProc; + /* Called to create a new object as a copy + * of an existing object. */ + Tcl_UpdateStringProc *updateStringProc; + /* Called to update the string rep from the + * type's internal representation. */ + Tcl_SetFromAnyProc *setFromAnyProc; + /* Called to convert the object's internal + * rep to this type. Frees the internal rep + * of the old type. Returns TCL_ERROR on + * failure. */ +} Tcl_ObjType; + +/* + * One of the following structures exists for each object in the Tcl + * system. An object stores a value as either a string, some internal + * representation, or both. + */ + +typedef struct Tcl_Obj { + int refCount; /* When 0 the object will be freed. */ + char *bytes; /* This points to the first byte of the + * object's string representation. The array + * must be followed by a null byte (i.e., at + * offset length) but may also contain + * embedded null characters. The array's + * storage is allocated by ckalloc. NULL + * means the string rep is invalid and must + * be regenerated from the internal rep. + * Clients should use Tcl_GetStringFromObj + * to get a pointer to the byte array as a + * readonly value. */ + int length; /* The number of bytes at *bytes, not + * including the terminating null. */ + Tcl_ObjType *typePtr; /* Denotes the object's type. Always + * corresponds to the type of the object's + * internal rep. NULL indicates the object + * has no internal rep (has no type). */ + union { /* The internal representation: */ + long longValue; /* - an long integer value */ + double doubleValue; /* - a double-precision floating value */ + VOID *otherValuePtr; /* - another, type-specific value */ + struct { /* - internal rep as two pointers */ + VOID *ptr1; + VOID *ptr2; + } twoPtrValue; + } internalRep; +} Tcl_Obj; + +/* + * Macros to increment and decrement a Tcl_Obj's reference count, and to + * test whether an object is shared (i.e. has reference count > 1). + * Note: clients should use Tcl_DecrRefCount() when they are finished using + * an object, and should never call TclFreeObj() directly. TclFreeObj() is + * only defined and made public in tcl.h to support Tcl_DecrRefCount's macro + * definition. Note also that Tcl_DecrRefCount() refers to the parameter + * "obj" twice. This means that you should avoid calling it with an + * expression that is expensive to compute or has side effects. + */ + +EXTERN void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); +EXTERN void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); +EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); + +#ifdef TCL_MEM_DEBUG +# define Tcl_IncrRefCount(objPtr) \ + Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__) +# define Tcl_DecrRefCount(objPtr) \ + Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) +# define Tcl_IsShared(objPtr) \ + Tcl_DbIsShared(objPtr, __FILE__, __LINE__) +#else +# define Tcl_IncrRefCount(objPtr) \ + ++(objPtr)->refCount +# define Tcl_DecrRefCount(objPtr) \ + if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr) +# define Tcl_IsShared(objPtr) \ + ((objPtr)->refCount > 1) +#endif + +/* + * Macros and definitions that help to debug the use of Tcl objects. + * When TCL_MEM_DEBUG is defined, the Tcl_New* declarations are + * overridden to call debugging versions of the object creation procedures. + */ + +EXTERN Tcl_Obj * Tcl_NewBooleanObj _ANSI_ARGS_((int boolValue)); +EXTERN Tcl_Obj * Tcl_NewDoubleObj _ANSI_ARGS_((double doubleValue)); +EXTERN Tcl_Obj * Tcl_NewIntObj _ANSI_ARGS_((int intValue)); +EXTERN Tcl_Obj * Tcl_NewListObj _ANSI_ARGS_((int objc, + Tcl_Obj *CONST objv[])); +EXTERN Tcl_Obj * Tcl_NewLongObj _ANSI_ARGS_((long longValue)); +EXTERN Tcl_Obj * Tcl_NewObj _ANSI_ARGS_((void)); +EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((char *bytes, + int length)); + +#ifdef TCL_MEM_DEBUG +# define Tcl_NewBooleanObj(val) \ + Tcl_DbNewBooleanObj(val, __FILE__, __LINE__) +# define Tcl_NewDoubleObj(val) \ + Tcl_DbNewDoubleObj(val, __FILE__, __LINE__) +# define Tcl_NewIntObj(val) \ + Tcl_DbNewLongObj(val, __FILE__, __LINE__) +# define Tcl_NewListObj(objc, objv) \ + Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__) +# define Tcl_NewLongObj(val) \ + Tcl_DbNewLongObj(val, __FILE__, __LINE__) +# define Tcl_NewObj() \ + Tcl_DbNewObj(__FILE__, __LINE__) +# define Tcl_NewStringObj(bytes, len) \ + Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__) +#endif /* TCL_MEM_DEBUG */ + +/* + * The following definitions support Tcl's namespace facility. + * Note: the first five fields must match exactly the fields in a + * Namespace structure (see tcl.h). + */ + +typedef struct Tcl_Namespace { + char *name; /* The namespace's name within its parent + * namespace. This contains no ::'s. The + * name of the global namespace is "" + * although "::" is an synonym. */ + char *fullName; /* The namespace's fully qualified name. + * This starts with ::. */ + ClientData clientData; /* Arbitrary value associated with this + * namespace. */ + Tcl_NamespaceDeleteProc* deleteProc; + /* Procedure invoked when deleting the + * namespace to, e.g., free clientData. */ + struct Tcl_Namespace* parentPtr; + /* Points to the namespace that contains + * this one. NULL if this is the global + * namespace. */ +} Tcl_Namespace; + +/* + * The following structure represents a call frame, or activation record. + * A call frame defines a naming context for a procedure call: its local + * scope (for local variables) and its namespace scope (used for non-local + * variables; often the global :: namespace). A call frame can also define + * the naming context for a namespace eval or namespace inscope command: + * the namespace in which the command's code should execute. The + * Tcl_CallFrame structures exist only while procedures or namespace + * eval/inscope's are being executed, and provide a Tcl call stack. + * + * A call frame is initialized and pushed using Tcl_PushCallFrame and + * popped using Tcl_PopCallFrame. Storage for a Tcl_CallFrame must be + * provided by the Tcl_PushCallFrame caller, and callers typically allocate + * them on the C call stack for efficiency. For this reason, Tcl_CallFrame + * is defined as a structure and not as an opaque token. However, most + * Tcl_CallFrame fields are hidden since applications should not access + * them directly; others are declared as "dummyX". + * + * WARNING!! The structure definition must be kept consistent with the + * CallFrame structure in tclInt.h. If you change one, change the other. + */ + +typedef struct Tcl_CallFrame { + Tcl_Namespace *nsPtr; + int dummy1; + int dummy2; + char *dummy3; + char *dummy4; + char *dummy5; + int dummy6; + char *dummy7; + char *dummy8; + int dummy9; + char* dummy10; +} Tcl_CallFrame; + +/* + * Information about commands that is returned by Tcl_GetCommandInfo and + * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based + * command procedure while proc is a traditional Tcl argc/argv + * string-based procedure. Tcl_CreateObjCommand and Tcl_CreateCommand + * ensure that both objProc and proc are non-NULL and can be called to + * execute the command. However, it may be faster to call one instead of + * the other. The member isNativeObjectProc is set to 1 if an + * object-based procedure was registered by Tcl_CreateObjCommand, and to + * 0 if a string-based procedure was registered by Tcl_CreateCommand. + * The other procedure is typically set to a compatibility wrapper that + * does string-to-object or object-to-string argument conversions then + * calls the other procedure. + */ + +typedef struct Tcl_CmdInfo { + int isNativeObjectProc; /* 1 if objProc was registered by a call to + * Tcl_CreateObjCommand; 0 otherwise. + * Tcl_SetCmdInfo does not modify this + * field. */ + Tcl_ObjCmdProc *objProc; /* Command's object-based procedure. */ + ClientData objClientData; /* ClientData for object proc. */ + Tcl_CmdProc *proc; /* Command's string-based procedure. */ + ClientData clientData; /* ClientData for string proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* Procedure to call when command is + * deleted. */ + ClientData deleteData; /* Value to pass to deleteProc (usually + * the same as clientData). */ + Tcl_Namespace *namespacePtr; /* Points to the namespace that contains + * this command. Note that Tcl_SetCmdInfo + * will not change a command's namespace; + * use Tcl_RenameCommand to do that. */ + +} Tcl_CmdInfo; + +/* + * The structure defined below is used to hold dynamic strings. The only + * field that clients should use is the string field, and they should + * never modify it. + */ + +#define TCL_DSTRING_STATIC_SIZE 200 +typedef struct Tcl_DString { + char *string; /* Points to beginning of string: either + * staticSpace below or a malloced array. */ + int length; /* Number of non-NULL characters in the + * string. */ + int spaceAvl; /* Total number of bytes available for the + * string and its terminating NULL char. */ + char staticSpace[TCL_DSTRING_STATIC_SIZE]; + /* Space to use in common case where string + * is small. */ +} Tcl_DString; + +#define Tcl_DStringLength(dsPtr) ((dsPtr)->length) +#define Tcl_DStringValue(dsPtr) ((dsPtr)->string) +#define Tcl_DStringTrunc Tcl_DStringSetLength + +/* + * Definitions for the maximum number of digits of precision that may + * be specified in the "tcl_precision" variable, and the number of + * characters of buffer space required by Tcl_PrintDouble. + */ + +#define TCL_MAX_PREC 17 +#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) + +/* + * Flag that may be passed to Tcl_ConvertElement to force it not to + * output braces (careful! if you change this flag be sure to change + * the definitions at the front of tclUtil.c). + */ + +#define TCL_DONT_USE_BRACES 1 + +/* + * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow + * abbreviated strings. + */ + +#define TCL_EXACT 1 + +/* + * Flag values passed to Tcl_RecordAndEval. + * WARNING: these bit choices must not conflict with the bit choices + * for evalFlag bits in tclInt.h!! + */ + +#define TCL_NO_EVAL 0x10000 +#define TCL_EVAL_GLOBAL 0x20000 + +/* + * Special freeProc values that may be passed to Tcl_SetResult (see + * the man page for details): + */ + +#define TCL_VOLATILE ((Tcl_FreeProc *) 1) +#define TCL_STATIC ((Tcl_FreeProc *) 0) +#define TCL_DYNAMIC ((Tcl_FreeProc *) 3) + +/* + * Flag values passed to variable-related procedures. + */ + +#define TCL_GLOBAL_ONLY 1 +#define TCL_NAMESPACE_ONLY 2 +#define TCL_APPEND_VALUE 4 +#define TCL_LIST_ELEMENT 8 +#define TCL_TRACE_READS 0x10 +#define TCL_TRACE_WRITES 0x20 +#define TCL_TRACE_UNSETS 0x40 +#define TCL_TRACE_DESTROYED 0x80 +#define TCL_INTERP_DESTROYED 0x100 +#define TCL_LEAVE_ERR_MSG 0x200 +#define TCL_PARSE_PART1 0x400 + +/* + * Types for linked variables: + */ + +#define TCL_LINK_INT 1 +#define TCL_LINK_DOUBLE 2 +#define TCL_LINK_BOOLEAN 3 +#define TCL_LINK_STRING 4 +#define TCL_LINK_READ_ONLY 0x80 + +/* + * The following declarations either map ckalloc and ckfree to + * malloc and free, or they map them to procedures with all sorts + * of debugging hooks defined in tclCkalloc.c. + */ + +EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size)); +EXTERN void Tcl_Free _ANSI_ARGS_((char *ptr)); +EXTERN char * Tcl_Realloc _ANSI_ARGS_((char *ptr, + unsigned int size)); + +#ifdef TCL_MEM_DEBUG + +# define Tcl_Alloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) +# define Tcl_Free(x) Tcl_DbCkfree(x, __FILE__, __LINE__) +# define Tcl_Realloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) +# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) +# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) +# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) + +EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); +EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, + int line)); + +#else + +/* CYGNUS LOCAL: Always use TCLALLOC. This means that calls to malloc + will always be checked to make sure that malloc succeeded. + + NOTE: In tcl8.1a2, the definition of TclpAlloc was removed from + unix/tclUnixPort.h. That means that in tcl8.1a2, this will wind up + calling the special allocator in tclAlloc.c, which would be bad. + When tcl 8.1 is imported, this needs to be checked. */ +#ifndef USE_TCLALLOC +#define USE_TCLALLOC 1 +#endif +/* END CYGNUS LOCAL */ + +# if USE_TCLALLOC +# define ckalloc(x) Tcl_Alloc(x) +# define ckfree(x) Tcl_Free(x) +# define ckrealloc(x,y) Tcl_Realloc(x,y) +# else +# define ckalloc(x) malloc(x) +# define ckfree(x) free(x) +# define ckrealloc(x,y) realloc(x,y) +# endif +# define Tcl_DumpActiveMemory(x) +# define Tcl_ValidateAllMemory(x,y) + +#endif /* TCL_MEM_DEBUG */ + +/* + * Forward declaration of Tcl_HashTable. Needed by some C++ compilers + * to prevent errors when the forward reference to Tcl_HashTable is + * encountered in the Tcl_HashEntry structure. + */ + +#ifdef __cplusplus +struct Tcl_HashTable; +#endif + +/* + * Structure definition for an entry in a hash table. No-one outside + * Tcl should access any of these fields directly; use the macros + * defined below. + */ + +typedef struct Tcl_HashEntry { + struct Tcl_HashEntry *nextPtr; /* Pointer to next entry in this + * hash bucket, or NULL for end of + * chain. */ + struct Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ + struct Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to + * first entry in this entry's chain: + * used for deleting the entry. */ + ClientData clientData; /* Application stores something here + * with Tcl_SetHashValue. */ + union { /* Key has one of these forms: */ + char *oneWordValue; /* One-word value for key. */ + int words[1]; /* Multiple integer words for key. + * The actual size will be as large + * as necessary for this table's + * keys. */ + char string[4]; /* String for key. The actual size + * will be as large as needed to hold + * the key. */ + } key; /* MUST BE LAST FIELD IN RECORD!! */ +} Tcl_HashEntry; + +/* + * Structure definition for a hash table. Must be in tcl.h so clients + * can allocate space for these structures, but clients should never + * access any fields in this structure. + */ + +#define TCL_SMALL_HASH_TABLE 4 +typedef struct Tcl_HashTable { + Tcl_HashEntry **buckets; /* Pointer to bucket array. Each + * element points to first entry in + * bucket's hash chain, or NULL. */ + Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; + /* Bucket array used for small tables + * (to avoid mallocs and frees). */ + int numBuckets; /* Total number of buckets allocated + * at **bucketPtr. */ + int numEntries; /* Total number of entries present + * in table. */ + int rebuildSize; /* Enlarge table when numEntries gets + * to be this large. */ + int downShift; /* Shift count used in hashing + * function. Designed to use high- + * order bits of randomized keys. */ + int mask; /* Mask value used in hashing + * function. */ + int keyType; /* Type of keys used in this table. + * It's either TCL_STRING_KEYS, + * TCL_ONE_WORD_KEYS, or an integer + * giving the number of ints that + * is the size of the key. + */ + Tcl_HashEntry *(*findProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, + CONST char *key)); + Tcl_HashEntry *(*createProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, + CONST char *key, int *newPtr)); +} Tcl_HashTable; + +/* + * Structure definition for information used to keep track of searches + * through hash tables: + */ + +typedef struct Tcl_HashSearch { + Tcl_HashTable *tablePtr; /* Table being searched. */ + int nextIndex; /* Index of next bucket to be + * enumerated after present one. */ + Tcl_HashEntry *nextEntryPtr; /* Next entry to be enumerated in the + * the current bucket. */ +} Tcl_HashSearch; + +/* + * Acceptable key types for hash tables: + */ + +#define TCL_STRING_KEYS 0 +#define TCL_ONE_WORD_KEYS 1 + +/* + * Macros for clients to use to access fields of hash entries: + */ + +#define Tcl_GetHashValue(h) ((h)->clientData) +#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value)) +#define Tcl_GetHashKey(tablePtr, h) \ + ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) ? (h)->key.oneWordValue \ + : (h)->key.string)) + +/* + * Macros to use for clients to use to invoke find and create procedures + * for hash tables: + */ + +#define Tcl_FindHashEntry(tablePtr, key) \ + (*((tablePtr)->findProc))(tablePtr, key) +#define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ + (*((tablePtr)->createProc))(tablePtr, key, newPtr) + +/* + * Flag values to pass to Tcl_DoOneEvent to disable searches + * for some kinds of events: + */ + +#define TCL_DONT_WAIT (1<<1) +#define TCL_WINDOW_EVENTS (1<<2) +#define TCL_FILE_EVENTS (1<<3) +#define TCL_TIMER_EVENTS (1<<4) +#define TCL_IDLE_EVENTS (1<<5) /* WAS 0x10 ???? */ +#define TCL_ALL_EVENTS (~TCL_DONT_WAIT) + +/* + * The following structure defines a generic event for the Tcl event + * system. These are the things that are queued in calls to Tcl_QueueEvent + * and serviced later by Tcl_DoOneEvent. There can be many different + * kinds of events with different fields, corresponding to window events, + * timer events, etc. The structure for a particular event consists of + * a Tcl_Event header followed by additional information specific to that + * event. + */ + +struct Tcl_Event { + Tcl_EventProc *proc; /* Procedure to call to service this event. */ + struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */ +}; + +/* + * Positions to pass to Tcl_QueueEvent: + */ + +typedef enum { + TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK +} Tcl_QueuePosition; + +/* + * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier + * event routines. + */ + +#define TCL_SERVICE_NONE 0 +#define TCL_SERVICE_ALL 1 + +/* + * The following structure keeps is used to hold a time value, either as + * an absolute time (the number of seconds from the epoch) or as an + * elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * On Macintosh systems the epoch is Midnight Jan 1, 1904 GMT. + */ + +typedef struct Tcl_Time { + long sec; /* Seconds. */ + long usec; /* Microseconds. */ +} Tcl_Time; + +/* + * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler + * to indicate what sorts of events are of interest: + */ + +#define TCL_READABLE (1<<1) +#define TCL_WRITABLE (1<<2) +#define TCL_EXCEPTION (1<<3) + +/* + * Flag values to pass to Tcl_OpenCommandChannel to indicate the + * disposition of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR, + * are also used in Tcl_GetStdChannel. + */ + +#define TCL_STDIN (1<<1) +#define TCL_STDOUT (1<<2) +#define TCL_STDERR (1<<3) +#define TCL_ENFORCE_MODE (1<<4) + +/* + * Typedefs for the various operations in a channel type: + */ + +typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_(( + ClientData instanceData, int mode)); +typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCodePtr)); +typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCodePtr)); +typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData, + long offset, int mode, int *errorCodePtr)); +typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_(( + ClientData instanceData, Tcl_Interp *interp, + char *optionName, char *value)); +typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_(( + ClientData instanceData, Tcl_Interp *interp, + char *optionName, Tcl_DString *dsPtr)); +typedef void (Tcl_DriverWatchProc) _ANSI_ARGS_(( + ClientData instanceData, int mask)); +typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_(( + ClientData instanceData, int direction, + ClientData *handlePtr)); + +/* + * Enum for different end of line translation and recognition modes. + */ + +typedef enum Tcl_EolTranslation { + TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */ + TCL_TRANSLATE_CR, /* Eol == \r. */ + TCL_TRANSLATE_LF, /* Eol == \n. */ + TCL_TRANSLATE_CRLF /* Eol == \r\n. */ +} Tcl_EolTranslation; + +/* + * struct Tcl_ChannelType: + * + * One such structure exists for each type (kind) of channel. + * It collects together in one place all the functions that are + * part of the specific channel type. + */ + +typedef struct Tcl_ChannelType { + char *typeName; /* The name of the channel type in Tcl + * commands. This storage is owned by + * channel type. */ + Tcl_DriverBlockModeProc *blockModeProc; + /* Set blocking mode for the + * raw channel. May be NULL. */ + Tcl_DriverCloseProc *closeProc; /* Procedure to call to close + * the channel. */ + Tcl_DriverInputProc *inputProc; /* Procedure to call for input + * on channel. */ + Tcl_DriverOutputProc *outputProc; /* Procedure to call for output + * on channel. */ + Tcl_DriverSeekProc *seekProc; /* Procedure to call to seek + * on the channel. May be NULL. */ + Tcl_DriverSetOptionProc *setOptionProc; + /* Set an option on a channel. */ + Tcl_DriverGetOptionProc *getOptionProc; + /* Get an option from a channel. */ + Tcl_DriverWatchProc *watchProc; /* Set up the notifier to watch + * for events on this channel. */ + Tcl_DriverGetHandleProc *getHandleProc; + /* Get an OS handle from the channel + * or NULL if not supported. */ + VOID *reserved; /* reserved for future expansion */ +} Tcl_ChannelType; + +/* + * The following flags determine whether the blockModeProc above should + * set the channel into blocking or nonblocking mode. They are passed + * as arguments to the blockModeProc procedure in the above structure. + */ + +#define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */ +#define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking + * mode. */ + +/* + * Enum for different types of file paths. + */ + +typedef enum Tcl_PathType { + TCL_PATH_ABSOLUTE, + TCL_PATH_RELATIVE, + TCL_PATH_VOLUME_RELATIVE +} Tcl_PathType; + +/* + * Exported Tcl procedures: + */ + +EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *message)); +EXTERN void Tcl_AddObjErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *message, int length)); +EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_AppendAllObjTypes _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr)); +EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +EXTERN void Tcl_AppendResult _ANSI_ARGS_( + TCL_VARARGS(Tcl_Interp *,interp)); +EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj *objPtr, + char *bytes, int length)); +EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_( + TCL_VARARGS(Tcl_Obj *,interp)); +EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc *proc, + ClientData clientData)); +EXTERN void Tcl_AsyncDelete _ANSI_ARGS_((Tcl_AsyncHandler async)); +EXTERN int Tcl_AsyncInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int code)); +EXTERN void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async)); +EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void)); +EXTERN void Tcl_BackgroundError _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN char Tcl_Backslash _ANSI_ARGS_((CONST char *src, + int *readPtr)); +EXTERN int Tcl_BadChannelOption _ANSI_ARGS_((Tcl_Interp *interp, + char *optionName, char *optionList)); +EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_InterpDeleteProc *proc, + ClientData clientData)); +EXTERN void Tcl_CancelIdleCall _ANSI_ARGS_((Tcl_IdleProc *idleProc, + ClientData clientData)); +#define Tcl_Ckalloc Tcl_Alloc +#define Tcl_Ckfree Tcl_Free +#define Tcl_Ckrealloc Tcl_Realloc +EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char *cmd)); +EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char **argv)); +EXTERN Tcl_Obj * Tcl_ConcatObj _ANSI_ARGS_((int objc, + Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_((CONST char *src, + int length, char *dst, int flags)); +EXTERN int Tcl_ConvertElement _ANSI_ARGS_((CONST char *src, + char *dst, int flags)); +EXTERN int Tcl_ConvertToType _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_ObjType *typePtr)); +EXTERN int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp *slave, + char *slaveCmd, Tcl_Interp *target, + char *targetCmd, int argc, char **argv)); +EXTERN int Tcl_CreateAliasObj _ANSI_ARGS_((Tcl_Interp *slave, + char *slaveCmd, Tcl_Interp *target, + char *targetCmd, int objc, + Tcl_Obj *CONST objv[])); +EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_(( + Tcl_ChannelType *typePtr, char *chanName, + ClientData instanceData, int mask)); +EXTERN void Tcl_CreateChannelHandler _ANSI_ARGS_(( + Tcl_Channel chan, int mask, + Tcl_ChannelProc *proc, ClientData clientData)); +EXTERN void Tcl_CreateCloseHandler _ANSI_ARGS_(( + Tcl_Channel chan, Tcl_CloseProc *proc, + ClientData clientData)); +EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdProc *proc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc)); +EXTERN void Tcl_CreateEventSource _ANSI_ARGS_(( + Tcl_EventSetupProc *setupProc, + Tcl_EventCheckProc *checkProc, + ClientData clientData)); +EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc, + ClientData clientData)); +EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_(( + int fd, int mask, Tcl_FileProc *proc, + ClientData clientData)); +EXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void)); +EXTERN void Tcl_CreateMathFunc _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int numArgs, Tcl_ValueType *argTypes, + Tcl_MathProc *proc, ClientData clientData)); +EXTERN Tcl_Command Tcl_CreateObjCommand _ANSI_ARGS_(( + Tcl_Interp *interp, char *cmdName, + Tcl_ObjCmdProc *proc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc)); +EXTERN Tcl_Interp * Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, + char *slaveName, int isSafe)); +EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds, + Tcl_TimerProc *proc, ClientData clientData)); +EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp *interp, + int level, Tcl_CmdTraceProc *proc, + ClientData clientData)); +EXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size, + char *file, int line)); +EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char *ptr, + char *file, int line)); +EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char *ptr, + unsigned int size, char *file, int line)); +EXTERN void Tcl_DbDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr, + char *file, int line)); +EXTERN void Tcl_DbIncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr, + char *file, int line)); +EXTERN int Tcl_DbIsShared _ANSI_ARGS_((Tcl_Obj *objPtr, + char *file, int line)); +EXTERN Tcl_Obj * Tcl_DbNewBooleanObj _ANSI_ARGS_((int boolValue, + char *file, int line)); +EXTERN Tcl_Obj * Tcl_DbNewDoubleObj _ANSI_ARGS_((double doubleValue, + char *file, int line)); +EXTERN Tcl_Obj * Tcl_DbNewListObj _ANSI_ARGS_((int objc, + Tcl_Obj *CONST objv[], char *file, int line)); +EXTERN Tcl_Obj * Tcl_DbNewLongObj _ANSI_ARGS_((long longValue, + char *file, int line)); +EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((char *file, int line)); +EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((char *bytes, + int length, char *file, int line)); +EXTERN void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp *interp, + char *name)); +EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName)); +EXTERN int Tcl_DeleteCommandFromToken _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Command command)); +EXTERN void Tcl_DeleteChannelHandler _ANSI_ARGS_(( + Tcl_Channel chan, Tcl_ChannelProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteCloseHandler _ANSI_ARGS_(( + Tcl_Channel chan, Tcl_CloseProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteEvents _ANSI_ARGS_(( + Tcl_EventDeleteProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteEventSource _ANSI_ARGS_(( + Tcl_EventSetupProc *setupProc, + Tcl_EventCheckProc *checkProc, + ClientData clientData)); +EXTERN void Tcl_DeleteExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_((int fd)); +EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_(( + Tcl_HashEntry *entryPtr)); +EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_(( + Tcl_HashTable *tablePtr)); +EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_DeleteTimerHandler _ANSI_ARGS_(( + Tcl_TimerToken token)); +EXTERN void Tcl_DeleteTrace _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Trace trace)); +EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, Tcl_Pid *pidPtr)); +EXTERN void Tcl_DontCallWhenDeleted _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, + ClientData clientData)); +EXTERN int Tcl_DoOneEvent _ANSI_ARGS_((int flags)); +EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc *proc, + ClientData clientData)); +EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString *dsPtr, + CONST char *string, int length)); +EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_(( + Tcl_DString *dsPtr, CONST char *string)); +EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_((Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringFree _ANSI_ARGS_((Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringGetResult _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringInit _ANSI_ARGS_((Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringResult _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringSetLength _ANSI_ARGS_((Tcl_DString *dsPtr, + int length)); +EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_(( + Tcl_DString *dsPtr)); +EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj *objPtr)); +EXTERN int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void)); +EXTERN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err)); +EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName)); +EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((ClientData clientData, + Tcl_FreeProc *freeProc)); +EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +EXTERN void Tcl_Exit _ANSI_ARGS_((int status)); +EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *hiddenCmdToken, char *cmdName)); +EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *ptr)); +EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int *ptr)); +EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp *interp, + char *string, double *ptr)); +EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, double *ptr)); +EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp *interp, + char *string, long *ptr)); +EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, long *ptr)); +EXTERN int Tcl_ExprObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr)); +EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +EXTERN void Tcl_Finalize _ANSI_ARGS_((void)); +EXTERN void Tcl_FindExecutable _ANSI_ARGS_((char *argv0)); +EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + Tcl_HashSearch *searchPtr)); +EXTERN int Tcl_Flush _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj *objPtr)); +EXTERN void Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp *interp, + char *slaveCmd, Tcl_Interp **targetInterpPtr, + char **targetCmdPtr, int *argcPtr, + char ***argvPtr)); +EXTERN int Tcl_GetAliasObj _ANSI_ARGS_((Tcl_Interp *interp, + char *slaveCmd, Tcl_Interp **targetInterpPtr, + char **targetCmdPtr, int *objcPtr, + Tcl_Obj ***objv)); +EXTERN ClientData Tcl_GetAssocData _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_InterpDeleteProc **procPtr)); +EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *boolPtr)); +EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr, + int *boolPtr)); +EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp *interp, + char *chanName, int *modePtr)); +EXTERN int Tcl_GetChannelBufferSize _ANSI_ARGS_(( + Tcl_Channel chan)); +EXTERN int Tcl_GetChannelHandle _ANSI_ARGS_((Tcl_Channel chan, + int direction, ClientData *handlePtr)); +EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_(( + Tcl_Channel chan)); +EXTERN int Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN char * Tcl_GetChannelName _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan, char *optionName, + Tcl_DString *dsPtr)); +EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdInfo *infoPtr)); +EXTERN char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Command command)); +EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp, + char *string, double *doublePtr)); +EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr, + double *doublePtr)); +EXTERN int Tcl_GetErrno _ANSI_ARGS_((void)); +EXTERN char * Tcl_GetHostName _ANSI_ARGS_((void)); +EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, char **tablePtr, char *msg, + int flags, int *indexPtr)); +EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *intPtr)); +EXTERN int Tcl_GetInterpPath _ANSI_ARGS_((Tcl_Interp *askInterp, + Tcl_Interp *slaveInterp)); +EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int *intPtr)); +EXTERN int Tcl_GetLongFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, long *longPtr)); +EXTERN Tcl_Interp * Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN CONST char * Tcl_GetNameOfExecutable _ANSI_ARGS_((void)); +EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tcl_ObjType * Tcl_GetObjType _ANSI_ARGS_((char *typeName)); +EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int write, int checkUsage, + ClientData *filePtr)); +EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((char *path)); +EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan, + Tcl_DString *dsPtr)); +EXTERN int Tcl_GetsObj _ANSI_ARGS_((Tcl_Channel chan, + Tcl_Obj *objPtr)); +EXTERN int Tcl_GetServiceMode _ANSI_ARGS_((void)); +EXTERN Tcl_Interp * Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp *interp, + char *slaveName)); +EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type)); +EXTERN char * Tcl_GetStringFromObj _ANSI_ARGS_((Tcl_Obj *objPtr, + int *lengthPtr)); +EXTERN char * Tcl_GetStringResult _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags)); +EXTERN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags)); +EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp *interp, + char *command)); +EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr)); +EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, char *hiddenCmdToken)); +EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr, + int keyType)); +EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_InputBlocked _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_InputBuffered _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_InterpDeleted _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_InvalidateStringRep _ANSI_ARGS_(( + Tcl_Obj *objPtr)); +EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, char **argv, + Tcl_DString *resultPtr)); +EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, char *addr, int type)); +EXTERN int Tcl_ListObjAppendList _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Obj *elemListPtr)); +EXTERN int Tcl_ListObjAppendElement _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Obj *objPtr)); +EXTERN int Tcl_ListObjGetElements _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *listPtr, + int *objcPtr, Tcl_Obj ***objvPtr)); +EXTERN int Tcl_ListObjIndex _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *listPtr, int index, + Tcl_Obj **objPtrPtr)); +EXTERN int Tcl_ListObjLength _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *listPtr, int *intPtr)); +EXTERN int Tcl_ListObjReplace _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *listPtr, int first, int count, + int objc, Tcl_Obj *CONST objv[])); +EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, + Tcl_AppInitProc *appInitProc)); +EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData handle, + int mode)); +EXTERN int Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tcl_Channel Tcl_MakeTcpClientChannel _ANSI_ARGS_(( + ClientData tcpSocket)); +EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char **argv)); +EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_(( + Tcl_HashSearch *searchPtr)); +EXTERN void Tcl_NotifyChannel _ANSI_ARGS_((Tcl_Channel channel, + int mask)); +EXTERN Tcl_Obj * Tcl_ObjGetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + int flags)); +EXTERN Tcl_Obj * Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + Tcl_Obj *newValuePtr, int flags)); +EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_(( + Tcl_Interp *interp, int argc, char **argv, + int flags)); +EXTERN Tcl_Channel Tcl_OpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *modeString, + int permissions)); +EXTERN Tcl_Channel Tcl_OpenTcpClient _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *address, char *myaddr, + int myport, int async)); +EXTERN Tcl_Channel Tcl_OpenTcpServer _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *host, + Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData)); +EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char **termPtr)); +EXTERN int Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp *interp, + char *name, char *version)); +EXTERN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp *interp, + char *name, char *version, int exact)); +EXTERN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_Preserve _ANSI_ARGS_((ClientData data)); +EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp *interp, + double value, char *dst)); +EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char *string)); +EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event *evPtr, + Tcl_QueuePosition position)); +EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan, + char *bufPtr, int toRead)); +EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void)); +EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp, + char *cmd, int flags)); +EXTERN int Tcl_RecordAndEvalObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *cmdPtr, int flags)); +EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_RegExp regexp, char *string, char *start)); +EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *pattern)); +EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, + int index, char **startPtr, char **endPtr)); +EXTERN void Tcl_RegisterChannel _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +EXTERN void Tcl_RegisterObjType _ANSI_ARGS_(( + Tcl_ObjType *typePtr)); +EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData)); +EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp)); +#define Tcl_Return Tcl_SetResult +EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char *string, + int length, int *flagPtr)); +EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char *string, + int *flagPtr)); +EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, + int offset, int mode)); +EXTERN int Tcl_ServiceAll _ANSI_ARGS_((void)); +EXTERN int Tcl_ServiceEvent _ANSI_ARGS_((int flags)); +EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_InterpDeleteProc *proc, + ClientData clientData)); +EXTERN void Tcl_SetBooleanObj _ANSI_ARGS_((Tcl_Obj *objPtr, + int boolValue)); +EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_(( + Tcl_Channel chan, int sz)); +EXTERN int Tcl_SetChannelOption _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Channel chan, + char *optionName, char *newValue)); +EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdInfo *infoPtr)); +EXTERN void Tcl_SetDoubleObj _ANSI_ARGS_((Tcl_Obj *objPtr, + double doubleValue)); +EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err)); +EXTERN void Tcl_SetErrorCode _ANSI_ARGS_( + TCL_VARARGS(Tcl_Interp *,arg1)); +EXTERN void Tcl_SetIntObj _ANSI_ARGS_((Tcl_Obj *objPtr, + int intValue)); +EXTERN void Tcl_SetListObj _ANSI_ARGS_((Tcl_Obj *objPtr, + int objc, Tcl_Obj *CONST objv[])); +EXTERN void Tcl_SetLongObj _ANSI_ARGS_((Tcl_Obj *objPtr, + long longValue)); +EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time *timePtr)); +EXTERN void Tcl_SetObjErrorCode _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *errorObjPtr)); +EXTERN void Tcl_SetObjLength _ANSI_ARGS_((Tcl_Obj *objPtr, + int length)); +EXTERN void Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *resultObjPtr)); +EXTERN void Tcl_SetPanicProc _ANSI_ARGS_((void (*proc) + _ANSI_ARGS_(TCL_VARARGS(char *, format)))); +EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp, + int depth)); +EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp *interp, + char *string, Tcl_FreeProc *freeProc)); +EXTERN int Tcl_SetServiceMode _ANSI_ARGS_((int mode)); +EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel, + int type)); +EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj *objPtr, + char *bytes, int length)); +EXTERN void Tcl_SetTimer _ANSI_ARGS_((Tcl_Time *timePtr)); +EXTERN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, char *newValue, int flags)); +EXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, char *newValue, + int flags)); +EXTERN char * Tcl_SignalId _ANSI_ARGS_((int sig)); +EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); +EXTERN void Tcl_Sleep _ANSI_ARGS_((int ms)); +EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp *interp, + char *list, int *argcPtr, char ***argvPtr)); +EXTERN void Tcl_SplitPath _ANSI_ARGS_((char *path, + int *argcPtr, char ***argvPtr)); +EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp *interp, + char *pkgName, Tcl_PackageInitProc *initProc, + Tcl_PackageInitProc *safeInitProc)); +EXTERN int Tcl_StringMatch _ANSI_ARGS_((char *string, + char *pattern)); +EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan)); +#define Tcl_TildeSubst Tcl_TranslateFileName +EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags, Tcl_VarTraceProc *proc, + ClientData clientData)); +EXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, + Tcl_VarTraceProc *proc, ClientData clientData)); +EXTERN char * Tcl_TranslateFileName _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_DString *bufferPtr)); +EXTERN int Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan, char *str, + int len, int atHead)); +EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName)); +EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +EXTERN int Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags)); +EXTERN int Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags)); +EXTERN void Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags, Tcl_VarTraceProc *proc, + ClientData clientData)); +EXTERN void Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, + Tcl_VarTraceProc *proc, ClientData clientData)); +EXTERN void Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName)); +EXTERN int Tcl_UpVar _ANSI_ARGS_((Tcl_Interp *interp, + char *frameName, char *varName, + char *localName, int flags)); +EXTERN int Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *frameName, char *part1, char *part2, + char *localName, int flags)); +EXTERN int Tcl_VarEval _ANSI_ARGS_( + TCL_VARARGS(Tcl_Interp *,interp)); +EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags, + Tcl_VarTraceProc *procPtr, + ClientData prevClientData)); +EXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, + Tcl_VarTraceProc *procPtr, + ClientData prevClientData)); +EXTERN int Tcl_WaitForEvent _ANSI_ARGS_((Tcl_Time *timePtr)); +EXTERN Tcl_Pid Tcl_WaitPid _ANSI_ARGS_((Tcl_Pid pid, int *statPtr, + int options)); +EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, + char *s, int slen)); +EXTERN void Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], char *message)); + +#endif /* RESOURCE_INCLUDED */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + +#endif /* _TCL */ diff --git a/tcl/generic/tclAlloc.c b/tcl/generic/tclAlloc.c new file mode 100644 index 00000000000..cdb0e3df5d8 --- /dev/null +++ b/tcl/generic/tclAlloc.c @@ -0,0 +1,458 @@ +/* + * tclAlloc.c -- + * + * This is a very fast storage allocator. It allocates blocks of a + * small number of different sizes, and keeps free lists of each size. + * Blocks that don't exactly fit are passed up to the next larger size. + * Blocks over a certain size are directly allocated from the system. + * + * Copyright (c) 1983 Regents of the University of California. + * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * + * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +#ifdef TCL_DEBUG +# define DEBUG +/* #define MSTATS */ +# define RCHECK +#endif + +#ifndef __CYGWIN32__ +typedef unsigned long caddr_t; +#endif + +/* + * The overhead on a block is at least 4 bytes. When free, this space + * contains a pointer to the next free block, and the bottom two bits must + * be zero. When in use, the first byte is set to MAGIC, and the second + * byte is the size index. The remaining bytes are for alignment. + * If range checking is enabled then a second word holds the size of the + * requested block, less 1, rounded up to a multiple of sizeof(RMAGIC). + * The order of elements is critical: ov_magic must overlay the low order + * bits of ov_next, and ov_magic can not be a valid ov_next bit pattern. + */ + +union overhead { + union overhead *ov_next; /* when free */ + struct { + unsigned char ovu_magic0; /* magic number */ + unsigned char ovu_index; /* bucket # */ + unsigned char ovu_unused; /* unused */ + unsigned char ovu_magic1; /* other magic number */ +#ifdef RCHECK + unsigned short ovu_rmagic; /* range magic number */ + unsigned long ovu_size; /* actual block size */ +#endif + } ovu; +#define ov_magic0 ovu.ovu_magic0 +#define ov_magic1 ovu.ovu_magic1 +#define ov_index ovu.ovu_index +#define ov_rmagic ovu.ovu_rmagic +#define ov_size ovu.ovu_size +}; + + +#define MAGIC 0xef /* magic # on accounting info */ +#define RMAGIC 0x5555 /* magic # on range info */ + +#ifdef RCHECK +#define RSLOP sizeof (unsigned short) +#else +#define RSLOP 0 +#endif + +#define OVERHEAD (sizeof(union overhead) + RSLOP) + +/* + * nextf[i] is the pointer to the next free block of size 2^(i+3). The + * smallest allocatable block is 8 bytes. The overhead information + * precedes the data area returned to the user. + */ + +#define NBUCKETS 13 +#define MAXMALLOC (1<<(NBUCKETS+2)) +static union overhead *nextf[NBUCKETS]; + +#ifdef MSTATS + +/* + * nmalloc[i] is the difference between the number of mallocs and frees + * for a given block size. + */ + +static unsigned int nmalloc[NBUCKETS+1]; +#include <stdio.h> +#endif + +#if defined(DEBUG) || defined(RCHECK) +#define ASSERT(p) if (!(p)) panic(# p) +#define RANGE_ASSERT(p) if (!(p)) panic(# p) +#else +#define ASSERT(p) +#define RANGE_ASSERT(p) +#endif + +/* + * Prototypes for functions used only in this file. + */ + +static void MoreCore _ANSI_ARGS_((int bucket)); + +/* + *---------------------------------------------------------------------- + * + * TclpAlloc -- + * + * Allocate more memory. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpAlloc( + unsigned int nbytes) /* Number of bytes to allocate. */ +{ + register union overhead *op; + register long bucket; + register unsigned amt; + + /* + * First the simple case: we simple allocate big blocks directly + */ + if (nbytes + OVERHEAD >= MAXMALLOC) { + op = (union overhead *)TclpSysAlloc(nbytes+OVERHEAD, 0); + if (op == NULL) { + return NULL; + } + op->ov_magic0 = op->ov_magic1 = MAGIC; + op->ov_index = 0xff; +#ifdef MSTATS + nmalloc[NBUCKETS]++; +#endif +#ifdef RCHECK + /* + * Record allocated size of block and + * bound space with magic numbers. + */ + op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); + op->ov_rmagic = RMAGIC; + *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; +#endif + return (void *)(op+1); + } + /* + * Convert amount of memory requested into closest block size + * stored in hash buckets which satisfies request. + * Account for space used per block for accounting. + */ +#ifndef RCHECK + amt = 8; /* size of first bucket */ + bucket = 0; +#else + amt = 16; /* size of first bucket */ + bucket = 1; +#endif + while (nbytes + OVERHEAD > amt) { + amt <<= 1; + if (amt == 0) { + return (NULL); + } + bucket++; + } + ASSERT( bucket < NBUCKETS ); + + /* + * If nothing in hash bucket right now, + * request more memory from the system. + */ + if ((op = nextf[bucket]) == NULL) { + MoreCore(bucket); + if ((op = nextf[bucket]) == NULL) { + return (NULL); + } + } + /* + * Remove from linked list + */ + nextf[bucket] = op->ov_next; + op->ov_magic0 = op->ov_magic1 = MAGIC; + op->ov_index = (unsigned char) bucket; +#ifdef MSTATS + nmalloc[bucket]++; +#endif +#ifdef RCHECK + /* + * Record allocated size of block and + * bound space with magic numbers. + */ + op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); + op->ov_rmagic = RMAGIC; + *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; +#endif + return ((char *)(op + 1)); +} + +/* + *---------------------------------------------------------------------- + * + * MoreCore -- + * + * Allocate more memory to the indicated bucket. + * + * Results: + * None. + * + * Side effects: + * Attempts to get more memory from the system. + * + *---------------------------------------------------------------------- + */ + +static void +MoreCore( + int bucket) /* What bucket to allocat to. */ +{ + register union overhead *op; + register long sz; /* size of desired block */ + long amt; /* amount to allocate */ + int nblks; /* how many blocks we get */ + + /* + * sbrk_size <= 0 only for big, FLUFFY, requests (about + * 2^30 bytes on a VAX, I think) or for a negative arg. + */ + sz = 1 << (bucket + 3); + ASSERT(sz > 0); + + amt = MAXMALLOC; + nblks = amt / sz; + ASSERT(nblks*sz == amt); + + op = (union overhead *)TclpSysAlloc(amt, 1); + /* no more room! */ + if (op == NULL) { + return; + } + + /* + * Add new memory allocated to that on + * free list for this hash bucket. + */ + nextf[bucket] = op; + while (--nblks > 0) { + op->ov_next = (union overhead *)((caddr_t)op + sz); + op = (union overhead *)((caddr_t)op + sz); + } + op->ov_next = (union overhead *)NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclpFree -- + * + * Free memory. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclpFree( + char *cp) /* Pointer to memory to free. */ +{ + register long size; + register union overhead *op; + + if (cp == NULL) { + return; + } + + op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); + + ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */ + ASSERT(op->ov_magic1 == MAGIC); + if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) { + return; + } + + RANGE_ASSERT(op->ov_rmagic == RMAGIC); + RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC); + size = op->ov_index; + if ( size == 0xff ) { +#ifdef MSTATS + nmalloc[NBUCKETS]--; +#endif + TclpSysFree(op); + return; + } + ASSERT(size < NBUCKETS); + op->ov_next = nextf[size]; /* also clobbers ov_magic */ + nextf[size] = op; +#ifdef MSTATS + nmalloc[size]--; +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclpRealloc -- + * + * Reallocate memory. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpRealloc( + char *cp, /* Pointer to alloced block. */ + unsigned int nbytes) /* New size of memory. */ +{ + int i; + union overhead *op; + int expensive; + unsigned long maxsize; + + if (cp == NULL) { + return (TclpAlloc(nbytes)); + } + + op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); + + ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */ + ASSERT(op->ov_magic1 == MAGIC); + if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) { + return NULL; + } + + RANGE_ASSERT(op->ov_rmagic == RMAGIC); + RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC); + i = op->ov_index; + + /* + * If the block isn't in a bin, just realloc it. + */ + + if (i == 0xff) { + op = (union overhead *) TclpSysRealloc(op, nbytes+OVERHEAD); + if (op == NULL) { + return NULL; + } +#ifdef MSTATS + nmalloc[NBUCKETS]++; +#endif +#ifdef RCHECK + /* + * Record allocated size of block and update magic number bounds. + */ + + op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); + *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; +#endif + return (char *)(op+1); + } + maxsize = 1 << (i+3); + expensive = 0; + if ( nbytes + OVERHEAD > maxsize ) { + expensive = 1; + } else if ( i > 0 && nbytes + OVERHEAD < (maxsize/2) ) { + expensive = 1; + } + + if (expensive) { + void *newp; + + newp = TclpAlloc(nbytes); + if ( newp == NULL ) { + return NULL; + } + maxsize -= OVERHEAD; + if ( maxsize < nbytes ) + nbytes = maxsize; + memcpy((VOID *) newp, (VOID *) cp, (size_t) nbytes); + TclpFree(cp); + return newp; + } + + /* + * Ok, we don't have to copy, it fits as-is + */ +#ifdef RCHECK + op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); + *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; +#endif + return(cp); +} + +/* + *---------------------------------------------------------------------- + * + * mstats -- + * + * Prints two lines of numbers, one showing the length of the + * free list for each size category, the second showing the + * number of mallocs - frees for each size category. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef MSTATS +void +mstats( + char *s) /* Where to write info. */ +{ + register int i, j; + register union overhead *p; + int totfree = 0, + totused = 0; + + fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); + for (i = 0; i < NBUCKETS; i++) { + for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) + fprintf(stderr, " %d", j); + totfree += j * (1 << (i + 3)); + } + fprintf(stderr, "\nused:\t"); + for (i = 0; i < NBUCKETS; i++) { + fprintf(stderr, " %d", nmalloc[i]); + totused += nmalloc[i] * (1 << (i + 3)); + } + fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", + totused, totfree); + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", + MAXMALLOC, nmalloc[NBUCKETS]); +} +#endif diff --git a/tcl/generic/tclAsync.c b/tcl/generic/tclAsync.c new file mode 100644 index 00000000000..2159d3f8342 --- /dev/null +++ b/tcl/generic/tclAsync.c @@ -0,0 +1,265 @@ +/* + * tclAsync.c -- + * + * This file provides low-level support needed to invoke signal + * handlers in a safe way. The code here doesn't actually handle + * signals, though. This code is based on proposals made by + * Mark Diekhans and Don Libes. + * + * Copyright (c) 1993 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * One of the following structures exists for each asynchronous + * handler: + */ + +typedef struct AsyncHandler { + int ready; /* Non-zero means this handler should + * be invoked in the next call to + * Tcl_AsyncInvoke. */ + struct AsyncHandler *nextPtr; /* Next in list of all handlers for + * the process. */ + Tcl_AsyncProc *proc; /* Procedure to call when handler + * is invoked. */ + ClientData clientData; /* Value to pass to handler when it + * is invoked. */ +} AsyncHandler; + +/* + * The variables below maintain a list of all existing handlers. + */ + +static AsyncHandler *firstHandler; /* First handler defined for process, + * or NULL if none. */ +static AsyncHandler *lastHandler; /* Last handler or NULL. */ + +/* + * The variable below is set to 1 whenever a handler becomes ready and + * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be + * checked elsewhere in the application by calling Tcl_AsyncReady to see + * if Tcl_AsyncInvoke should be invoked. + */ + +static int asyncReady = 0; + +/* + * The variable below indicates whether Tcl_AsyncInvoke is currently + * working. If so then we won't set asyncReady again until + * Tcl_AsyncInvoke returns. + */ + +static int asyncActive = 0; + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncCreate -- + * + * This procedure creates the data structures for an asynchronous + * handler, so that no memory has to be allocated when the handler + * is activated. + * + * Results: + * The return value is a token for the handler, which can be used + * to activate it later on. + * + * Side effects: + * Information about the handler is recorded. + * + *---------------------------------------------------------------------- + */ + +Tcl_AsyncHandler +Tcl_AsyncCreate(proc, clientData) + Tcl_AsyncProc *proc; /* Procedure to call when handler + * is invoked. */ + ClientData clientData; /* Argument to pass to handler. */ +{ + AsyncHandler *asyncPtr; + + asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler)); + asyncPtr->ready = 0; + asyncPtr->nextPtr = NULL; + asyncPtr->proc = proc; + asyncPtr->clientData = clientData; + if (firstHandler == NULL) { + firstHandler = asyncPtr; + } else { + lastHandler->nextPtr = asyncPtr; + } + lastHandler = asyncPtr; + return (Tcl_AsyncHandler) asyncPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncMark -- + * + * This procedure is called to request that an asynchronous handler + * be invoked as soon as possible. It's typically called from + * an interrupt handler, where it isn't safe to do anything that + * depends on or modifies application state. + * + * Results: + * None. + * + * Side effects: + * The handler gets marked for invocation later. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AsyncMark(async) + Tcl_AsyncHandler async; /* Token for handler. */ +{ + ((AsyncHandler *) async)->ready = 1; + if (!asyncActive) { + asyncReady = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncInvoke -- + * + * This procedure is called at a "safe" time at background level + * to invoke any active asynchronous handlers. + * + * Results: + * The return value is a normal Tcl result, which is intended to + * replace the code argument as the current completion code for + * interp. + * + * Side effects: + * Depends on the handlers that are active. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AsyncInvoke(interp, code) + Tcl_Interp *interp; /* If invoked from Tcl_Eval just after + * completing a command, points to + * interpreter. Otherwise it is + * NULL. */ + int code; /* If interp is non-NULL, this gives + * completion code from command that + * just completed. */ +{ + AsyncHandler *asyncPtr; + + if (asyncReady == 0) { + return code; + } + asyncReady = 0; + asyncActive = 1; + if (interp == NULL) { + code = 0; + } + + /* + * Make one or more passes over the list of handlers, invoking + * at most one handler in each pass. After invoking a handler, + * go back to the start of the list again so that (a) if a new + * higher-priority handler gets marked while executing a lower + * priority handler, we execute the higher-priority handler + * next, and (b) if a handler gets deleted during the execution + * of a handler, then the list structure may change so it isn't + * safe to continue down the list anyway. + */ + + while (1) { + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->ready) { + break; + } + } + if (asyncPtr == NULL) { + break; + } + asyncPtr->ready = 0; + code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code); + } + asyncActive = 0; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncDelete -- + * + * Frees up all the state for an asynchronous handler. The handler + * should never be used again. + * + * Results: + * None. + * + * Side effects: + * The state associated with the handler is deleted. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AsyncDelete(async) + Tcl_AsyncHandler async; /* Token for handler to delete. */ +{ + AsyncHandler *asyncPtr = (AsyncHandler *) async; + AsyncHandler *prevPtr; + + if (firstHandler == asyncPtr) { + firstHandler = asyncPtr->nextPtr; + if (firstHandler == NULL) { + lastHandler = NULL; + } + } else { + prevPtr = firstHandler; + while (prevPtr->nextPtr != asyncPtr) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = asyncPtr->nextPtr; + if (lastHandler == asyncPtr) { + lastHandler = prevPtr; + } + } + ckfree((char *) asyncPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncReady -- + * + * This procedure can be used to tell whether Tcl_AsyncInvoke + * needs to be called. This procedure is the external interface + * for checking the internal asyncReady variable. + * + * Results: + * The return value is 1 whenever a handler is ready and is 0 + * when no handlers are ready. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AsyncReady() +{ + return asyncReady; +} diff --git a/tcl/generic/tclBasic.c b/tcl/generic/tclBasic.c new file mode 100644 index 00000000000..044974cb13a --- /dev/null +++ b/tcl/generic/tclBasic.c @@ -0,0 +1,4094 @@ +/* + * tclBasic.c -- + * + * Contains the basic facilities for TCL command interpretation, + * including interpreter creation and deletion, command creation + * and deletion, and command parsing and execution. + * + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclCompile.h" +#ifndef TCL_GENERIC_ONLY +# include "tclPort.h" +#endif + +/* + * Static procedures in this file: + */ + +static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); +static void HiddenCmdsDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); + +/* + * The following structure defines the commands in the Tcl core. + */ + +typedef struct { + char *name; /* Name of object-based command. */ + Tcl_CmdProc *proc; /* String-based procedure for command. */ + Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */ + CompileProc *compileProc; /* Procedure called to compile command. */ + int isSafe; /* If non-zero, command will be present + * in safe interpreter. Otherwise it will + * be hidden. */ +} CmdInfo; + +/* + * The built-in commands, and the procedures that implement them: + */ + +static CmdInfo builtInCmds[] = { + /* + * Commands in the generic core. Note that at least one of the proc or + * objProc members should be non-NULL. This avoids infinitely recursive + * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a + * command name is computed at runtime and results in the name of a + * compiled command. + */ + + {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd, + (CompileProc *) NULL, 1}, + {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd, + (CompileProc *) NULL, 1}, + {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, + (CompileProc *) NULL, 1}, + {"break", Tcl_BreakCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileBreakCmd, 1}, + {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, + (CompileProc *) NULL, 1}, + {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd, + TclCompileCatchCmd, 1}, + {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd, + (CompileProc *) NULL, 1}, + {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, + (CompileProc *) NULL, 1}, + {"continue", Tcl_ContinueCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileContinueCmd, 1}, + {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, + (CompileProc *) NULL, 1}, + {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd, + (CompileProc *) NULL, 1}, + {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd, + (CompileProc *) NULL, 0}, + {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd, + TclCompileExprCmd, 1}, + {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, + (CompileProc *) NULL, 1}, + {"fileevent", Tcl_FileEventCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"for", Tcl_ForCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileForCmd, 1}, + {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, + TclCompileForeachCmd, 1}, + {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd, + (CompileProc *) NULL, 1}, + {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, + (CompileProc *) NULL, 1}, + {"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileIfCmd, 1}, + {"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileIncrCmd, 1}, + {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, + (CompileProc *) NULL, 1}, + {"interp", (Tcl_CmdProc *) NULL, Tcl_InterpObjCmd, + (CompileProc *) NULL, 1}, + {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, + (CompileProc *) NULL, 1}, + {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, + (CompileProc *) NULL, 1}, + {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, + (CompileProc *) NULL, 1}, + {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, + (CompileProc *) NULL, 1}, + {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd, + (CompileProc *) NULL, 1}, + {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, + (CompileProc *) NULL, 1}, + {"load", Tcl_LoadCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, + (CompileProc *) NULL, 1}, + {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd, + (CompileProc *) NULL, 1}, + {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd, + (CompileProc *) NULL, 1}, + {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd, + (CompileProc *) NULL, 1}, + {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, + (CompileProc *) NULL, 1}, + {"package", Tcl_PackageCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, + (CompileProc *) NULL, 1}, + {"regexp", Tcl_RegexpCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"regsub", Tcl_RegsubCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, + (CompileProc *) NULL, 1}, + {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, + (CompileProc *) NULL, 1}, + {"scan", Tcl_ScanCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileSetCmd, 1}, + {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, + (CompileProc *) NULL, 1}, + {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, + (CompileProc *) NULL, 1}, + {"subst", Tcl_SubstCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, + (CompileProc *) NULL, 1}, + {"trace", Tcl_TraceCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, + (CompileProc *) NULL, 1}, + {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd, + (CompileProc *) NULL, 1}, + {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd, + (CompileProc *) NULL, 1}, + {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, + (CompileProc *) NULL, 1}, + {"while", Tcl_WhileCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileWhileCmd, 1}, + + /* + * Commands in the UNIX core: + */ + +#ifndef TCL_GENERIC_ONLY + {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd, + (CompileProc *) NULL, 1}, + {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd, + (CompileProc *) NULL, 0}, + {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd, + (CompileProc *) NULL, 1}, + {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd, + (CompileProc *) NULL, 1}, + {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, + (CompileProc *) NULL, 1}, + {"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, + (CompileProc *) NULL, 0}, + {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd, + (CompileProc *) NULL, 1}, + {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, + (CompileProc *) NULL, 1}, + {"glob", Tcl_GlobCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"open", Tcl_OpenCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd, + (CompileProc *) NULL, 1}, + {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, + (CompileProc *) NULL, 1}, + {"pwd", Tcl_PwdCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, + (CompileProc *) NULL, 1}, + {"seek", Tcl_SeekCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"socket", Tcl_SocketCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"tell", Tcl_TellCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, + (CompileProc *) NULL, 1}, + {"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + +#ifdef MAC_TCL + {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd, + (CompileProc *) NULL, 0}, + {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"ls", Tcl_LsCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd, + (CompileProc *) NULL, 1}, + {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd, + (CompileProc *) NULL, 0}, +#else + {"exec", Tcl_ExecCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, + (CompileProc *) NULL, 0}, +#endif /* MAC_TCL */ + +#endif /* TCL_GENERIC_ONLY */ + {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0} +}; + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateInterp -- + * + * Create a new TCL command interpreter. + * + * Results: + * The return value is a token for the interpreter, which may be + * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or + * Tcl_DeleteInterp. + * + * Side effects: + * The command interpreter is initialized with an empty variable + * table and the built-in commands. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_CreateInterp() +{ + register Interp *iPtr; + register Command *cmdPtr; + register CmdInfo *cmdInfoPtr; + union { + char c[sizeof(short)]; + short s; + } order; + int i; + + /* + * Panic if someone updated the CallFrame structure without + * also updating the Tcl_CallFrame structure (or vice versa). + */ + + if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) { + /*NOTREACHED*/ + panic("Tcl_CallFrame and CallFrame are not the same size"); + } + + /* + * Initialize support for namespaces and create the global namespace + * (whose name is ""; an alias is "::"). This also initializes the + * Tcl object type table and other object management code. + */ + + TclInitNamespaces(); + + iPtr = (Interp *) ckalloc(sizeof(Interp)); + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + iPtr->objResultPtr = Tcl_NewObj(); /* an empty object */ + Tcl_IncrRefCount(iPtr->objResultPtr); + iPtr->errorLine = 0; + Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); + iPtr->numLevels = 0; + iPtr->maxNestingDepth = 1000; + iPtr->framePtr = NULL; + iPtr->varFramePtr = NULL; + iPtr->activeTracePtr = NULL; + iPtr->returnCode = TCL_OK; + iPtr->errorInfo = NULL; + iPtr->errorCode = NULL; + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + iPtr->appendUsed = 0; + for (i = 0; i < NUM_REGEXPS; i++) { + iPtr->patterns[i] = NULL; + iPtr->patLengths[i] = -1; + iPtr->regexps[i] = NULL; + } + Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); + iPtr->packageUnknown = NULL; + iPtr->cmdCount = 0; + iPtr->termOffset = 0; + iPtr->compileEpoch = 0; + iPtr->compiledProcPtr = NULL; + iPtr->resolverPtr = NULL; + iPtr->evalFlags = 0; + iPtr->scriptFile = NULL; + iPtr->flags = 0; + iPtr->tracePtr = NULL; + iPtr->assocData = (Tcl_HashTable *) NULL; + iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ + iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ + Tcl_IncrRefCount(iPtr->emptyObjPtr); + iPtr->resultSpace[0] = 0; + + iPtr->globalNsPtr = NULL; /* force creation of global ns below */ + iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace( + (Tcl_Interp *) iPtr, "", (ClientData) NULL, + (Tcl_NamespaceDeleteProc *) NULL); + if (iPtr->globalNsPtr == NULL) { + panic("Tcl_CreateInterp: can't create global namespace"); + } + + /* + * Initialize support for code compilation. Do this after initializing + * namespaces since TclCreateExecEnv will try to reference a Tcl + * variable (it links to the Tcl "tcl_traceExec" variable). + */ + + iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr); + + /* + * Create the core commands. Do it here, rather than calling + * Tcl_CreateCommand, because it's faster (there's no need to check for + * a pre-existing command by the same name). If a command has a + * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to + * TclInvokeStringCommand. This is an object-based wrapper procedure + * that extracts strings, calls the string procedure, and creates an + * object for the result. Similarly, if a command has a Tcl_ObjCmdProc + * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. + */ + + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; + cmdInfoPtr++) { + int new; + Tcl_HashEntry *hPtr; + + if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) + && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) + && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { + panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n"); + } + + hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, + cmdInfoPtr->name, &new); + if (new) { + cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = iPtr->globalNsPtr; + cmdPtr->refCount = 1; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = cmdInfoPtr->compileProc; + if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) { + cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->clientData = (ClientData) cmdPtr; + } else { + cmdPtr->proc = cmdInfoPtr->proc; + cmdPtr->clientData = (ClientData) NULL; + } + if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { + cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objClientData = (ClientData) cmdPtr; + } else { + cmdPtr->objProc = cmdInfoPtr->objProc; + cmdPtr->objClientData = (ClientData) NULL; + } + cmdPtr->deleteProc = NULL; + cmdPtr->deleteData = (ClientData) NULL; + cmdPtr->deleted = 0; + cmdPtr->importRefPtr = NULL; + Tcl_SetHashValue(hPtr, cmdPtr); + } + } + + /* + * Initialize/Create "errorInfo" and "errorCode" global vars + * (because some part of the C code assume they exists + * and we can get a seg fault otherwise (in multiple + * interps loading of extensions for instance) --dl) + */ + /* + * We can't assume that because we initialize + * the variables here, they won't be unset later. + * so we had 2 choices: + * + Check every place where a GetVar of those is used + * and the NULL result is not checked (like in tclLoad.c) + * + Make SetVar,... NULL friendly + * We choosed the second option because : + * + It is easy and low cost to check for NULL pointer before + * calling strlen() + * + It can be helpfull to other people using those API + * + Passing a NULL value to those closest 'meaning' is empty string + * (specially with the new objects where 0 bytes strings are ok) + * So the following init is commented out: -- dl + */ + /* + (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "", + TCL_GLOBAL_ONLY); + (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE", + TCL_GLOBAL_ONLY); + */ + +#ifndef TCL_GENERIC_ONLY + TclSetupEnv((Tcl_Interp *) iPtr); +#endif + + /* + * Do Multiple/Safe Interps Tcl init stuff + */ + (void) TclInterpInit((Tcl_Interp *)iPtr); + + /* + * Set up variables such as tcl_version. + */ + + TclPlatformInit((Tcl_Interp *)iPtr); + Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL, + TCL_GLOBAL_ONLY); + Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION, + TCL_GLOBAL_ONLY); + Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, (ClientData) NULL); + + /* + * Compute the byte order of this machine. + */ + + order.s = 1; + Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder", + (order.c[0] == 1) ? "littleEndian" : "bigEndian", + TCL_GLOBAL_ONLY); + + /* + * Register Tcl's version number. + */ + + Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION); + + return (Tcl_Interp *) iPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclHideUnsafeCommands -- + * + * Hides base commands that are not marked as safe from this + * interpreter. + * + * Results: + * TCL_OK if it succeeds, TCL_ERROR else. + * + * Side effects: + * Hides functionality in an interpreter. + * + *---------------------------------------------------------------------- + */ + +int +TclHideUnsafeCommands(interp) + Tcl_Interp *interp; /* Hide commands in this interpreter. */ +{ + register CmdInfo *cmdInfoPtr; + + if (interp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + if (!cmdInfoPtr->isSafe) { + Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); + } + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_CallWhenDeleted -- + * + * Arrange for a procedure to be called before a given + * interpreter is deleted. The procedure is called as soon + * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is + * called on an interpreter that has already been deleted, + * the procedure will be called when the last Tcl_Release is + * done on the interpreter. + * + * Results: + * None. + * + * Side effects: + * When Tcl_DeleteInterp is invoked to delete interp, + * proc will be invoked. See the manual entry for + * details. + * + *-------------------------------------------------------------- + */ + +void +Tcl_CallWhenDeleted(interp, proc, clientData) + Tcl_Interp *interp; /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter + * is about to be deleted. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + static int assocDataCounter = 0; + int new; + char buffer[128]; + AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + Tcl_HashEntry *hPtr; + + sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); + assocDataCounter++; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + } + hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); + dPtr->proc = proc; + dPtr->clientData = clientData; + Tcl_SetHashValue(hPtr, dPtr); +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DontCallWhenDeleted -- + * + * Cancel the arrangement for a procedure to be called when + * a given interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * If proc and clientData were previously registered as a + * callback via Tcl_CallWhenDeleted, they are unregistered. + * If they weren't previously registered then nothing + * happens. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DontCallWhenDeleted(interp, proc, clientData) + Tcl_Interp *interp; /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter + * is about to be deleted. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTablePtr; + Tcl_HashSearch hSearch; + Tcl_HashEntry *hPtr; + AssocData *dPtr; + + hTablePtr = iPtr->assocData; + if (hTablePtr == (Tcl_HashTable *) NULL) { + return; + } + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetAssocData -- + * + * Creates a named association between user-specified data, a delete + * function and this interpreter. If the association already exists + * the data is overwritten with the new data. The delete function will + * be invoked when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * Sets the associated data, creates the association if needed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetAssocData(interp, name, proc, clientData) + Tcl_Interp *interp; /* Interpreter to associate with. */ + char *name; /* Name for association. */ + Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is + * about to be deleted. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + int new; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + } + hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); + if (new == 0) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + } else { + dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + } + dPtr->proc = proc; + dPtr->clientData = clientData; + + Tcl_SetHashValue(hPtr, dPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteAssocData -- + * + * Deletes a named association of user-specified data with + * the specified interpreter. + * + * Results: + * None. + * + * Side effects: + * Deletes the association. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteAssocData(interp, name) + Tcl_Interp *interp; /* Interpreter to associate with. */ + char *name; /* Name of association. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + return; + } + hPtr = Tcl_FindHashEntry(iPtr->assocData, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + return; + } + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if (dPtr->proc != NULL) { + (dPtr->proc) (dPtr->clientData, interp); + } + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetAssocData -- + * + * Returns the client data associated with this name in the + * specified interpreter. + * + * Results: + * The client data in the AssocData record denoted by the named + * association, or NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_GetAssocData(interp, name, procPtr) + Tcl_Interp *interp; /* Interpreter associated with. */ + char *name; /* Name of association. */ + Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address + * of current deletion callback. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + return (ClientData) NULL; + } + hPtr = Tcl_FindHashEntry(iPtr->assocData, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + return (ClientData) NULL; + } + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if (procPtr != (Tcl_InterpDeleteProc **) NULL) { + *procPtr = dPtr->proc; + } + return dPtr->clientData; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteInterpProc -- + * + * Helper procedure to delete an interpreter. This procedure is + * called when the last call to Tcl_Preserve on this interpreter + * is matched by a call to Tcl_Release. The procedure cleans up + * all resources used in the interpreter and calls all currently + * registered interpreter deletion callbacks. + * + * Results: + * None. + * + * Side effects: + * Whatever the interpreter deletion callbacks do. Frees resources + * used by the interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteInterpProc(interp) + Tcl_Interp *interp; /* Interpreter to delete. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable *hTablePtr; + AssocData *dPtr; + ResolverScheme *resPtr, *nextResPtr; + int i; + + /* + * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. + */ + + if (iPtr->numLevels > 0) { + panic("DeleteInterpProc called with active evals"); + } + + /* + * The interpreter should already be marked deleted; otherwise how + * did we get here? + */ + + if (!(iPtr->flags & DELETED)) { + panic("DeleteInterpProc called on interpreter not marked deleted"); + } + + /* + * Dismantle everything in the global namespace except for the + * "errorInfo" and "errorCode" variables. These remain until the + * namespace is actually destroyed, in case any errors occur. + * + * Dismantle the namespace here, before we clear the assocData. If any + * background errors occur here, they will be deleted below. + */ + + TclTeardownNamespace(iPtr->globalNsPtr); + + /* + * Tear down the math function table. + */ + + for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&iPtr->mathFuncTable); + + /* + * Invoke deletion callbacks; note that a callback can create new + * callbacks, so we iterate. + */ + + while (iPtr->assocData != (Tcl_HashTable *) NULL) { + hTablePtr = iPtr->assocData; + iPtr->assocData = (Tcl_HashTable *) NULL; + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (dPtr->proc != NULL) { + (*dPtr->proc)(dPtr->clientData, interp); + } + ckfree((char *) dPtr); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree((char *) hTablePtr); + } + + /* + * Finish deleting the global namespace. + */ + + Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); + + /* + * Free up the result *after* deleting variables, since variable + * deletion could have transferred ownership of the result string + * to Tcl. + */ + + Tcl_FreeResult(interp); + interp->result = NULL; + Tcl_DecrRefCount(iPtr->objResultPtr); + iPtr->objResultPtr = NULL; + if (iPtr->errorInfo != NULL) { + ckfree(iPtr->errorInfo); + iPtr->errorInfo = NULL; + } + if (iPtr->errorCode != NULL) { + ckfree(iPtr->errorCode); + iPtr->errorCode = NULL; + } + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + } + for (i = 0; i < NUM_REGEXPS; i++) { + if (iPtr->patterns[i] == NULL) { + break; + } + ckfree(iPtr->patterns[i]); + ckfree((char *) iPtr->regexps[i]); + iPtr->regexps[i] = NULL; + } + TclFreePackageInfo(iPtr); + while (iPtr->tracePtr != NULL) { + Trace *nextPtr = iPtr->tracePtr->nextPtr; + + ckfree((char *) iPtr->tracePtr); + iPtr->tracePtr = nextPtr; + } + if (iPtr->execEnvPtr != NULL) { + TclDeleteExecEnv(iPtr->execEnvPtr); + } + Tcl_DecrRefCount(iPtr->emptyObjPtr); + iPtr->emptyObjPtr = NULL; + + resPtr = iPtr->resolverPtr; + while (resPtr) { + nextResPtr = resPtr->nextPtr; + ckfree(resPtr->name); + ckfree((char *) resPtr); + resPtr = nextResPtr; + } + + ckfree((char *) iPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InterpDeleted -- + * + * Returns nonzero if the interpreter has been deleted with a call + * to Tcl_DeleteInterp. + * + * Results: + * Nonzero if the interpreter is deleted, zero otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InterpDeleted(interp) + Tcl_Interp *interp; +{ + return (((Interp *) interp)->flags & DELETED) ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteInterp -- + * + * Ensures that the interpreter will be deleted eventually. If there + * are no Tcl_Preserve calls in effect for this interpreter, it is + * deleted immediately, otherwise the interpreter is deleted when + * the last Tcl_Preserve is matched by a call to Tcl_Release. In either + * case, the procedure runs the currently registered deletion callbacks. + * + * Results: + * None. + * + * Side effects: + * The interpreter is marked as deleted. The caller may still use it + * safely if there are calls to Tcl_Preserve in effect for the + * interpreter, but further calls to Tcl_Eval etc in this interpreter + * will fail. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteInterp(interp) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ +{ + Interp *iPtr = (Interp *) interp; + + /* + * If the interpreter has already been marked deleted, just punt. + */ + + if (iPtr->flags & DELETED) { + return; + } + + /* + * Mark the interpreter as deleted. No further evals will be allowed. + */ + + iPtr->flags |= DELETED; + + /* + * Ensure that the interpreter is eventually deleted. + */ + + Tcl_EventuallyFree((ClientData) interp, + (Tcl_FreeProc *) DeleteInterpProc); +} + +/* + *---------------------------------------------------------------------- + * + * HiddenCmdsDeleteProc -- + * + * Called on interpreter deletion to delete all the hidden + * commands in an interpreter. + * + * Results: + * None. + * + * Side effects: + * Frees up memory. + * + *---------------------------------------------------------------------- + */ + +static void +HiddenCmdsDeleteProc(clientData, interp) + ClientData clientData; /* The hidden commands hash table. */ + Tcl_Interp *interp; /* The interpreter being deleted. */ +{ + Tcl_HashTable *hiddenCmdTblPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + Command *cmdPtr; + + hiddenCmdTblPtr = (Tcl_HashTable *) clientData; + for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) { + + /* + * Cannot use Tcl_DeleteCommand because (a) the command is not + * in the command hash table, and (b) that table has already been + * deleted above. Hence we emulate what it does, below. + */ + + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + /* + * The code here is tricky. We can't delete the hash table entry + * before invoking the deletion callback because there are cases + * where the deletion callback needs to invoke the command (e.g. + * object systems such as OTcl). However, this means that the + * callback could try to delete or rename the command. The deleted + * flag allows us to detect these cases and skip nested deletes. + */ + + if (cmdPtr->deleted) { + + /* + * Another deletion is already in progress. Remove the hash + * table entry now, but don't invoke a callback or free the + * command structure. + */ + + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + continue; + } + cmdPtr->deleted = 1; + if (cmdPtr->deleteProc != NULL) { + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that refer to this command. + */ + + cmdPtr->cmdEpoch++; + + /* + * Don't use hPtr to delete the hash entry here, because it's + * possible that the deletion callback renamed the command. + * Instead, use cmdPtr->hptr, and make sure that no-one else + * has already deleted the hash entry. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + } + + /* + * Now free the Command structure, unless there is another reference + * to it from a CmdName Tcl object in some ByteCode code + * sequence. In that case, delay the cleanup until all references + * are either discarded (when a ByteCode is freed) or replaced by a + * new reference (when a cached CmdName Command reference is found + * to be invalid and TclExecuteByteCode looks up the command in the + * command hashtable). + */ + + TclCleanupCommand(cmdPtr); + } + Tcl_DeleteHashTable(hiddenCmdTblPtr); + ckfree((char *) hiddenCmdTblPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_HideCommand -- + * + * Makes a command hidden so that it cannot be invoked from within + * an interpreter, only from within an ancestor. + * + * Results: + * A standard Tcl result; also leaves a message in interp->result + * if an error occurs. + * + * Side effects: + * Removes a command from the command table and create an entry + * into the hidden command table under the specified token name. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_HideCommand(interp, cmdName, hiddenCmdToken) + Tcl_Interp *interp; /* Interpreter in which to hide command. */ + char *cmdName; /* Name of command to hide. */ + char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Command cmd; + Command *cmdPtr; + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + int new; + + if (iPtr->flags & DELETED) { + + /* + * The interpreter is being deleted. Do not create any new + * structures, because it is not safe to modify the interpreter. + */ + + return TCL_ERROR; + } + + /* + * Disallow hiding of commands that are currently in a namespace or + * renaming (as part of hiding) into a namespace. + * + * (because the current implementation with a single global table + * and the needed uniqueness of names cause problems with namespaces) + * + * we don't need to check for "::" in cmdName because the real check is + * on the nsPtr below. + * + * hiddenCmdToken is just a string which is not interpreted in any way. + * It may contain :: but the string is not interpreted as a namespace + * qualifier command name. Thus, hiding foo::bar to foo::bar and then + * trying to expose or invoke ::foo::bar will NOT work; but if the + * application always uses the same strings it will get consistent + * behaviour. + * + * But as we currently limit ourselves to the global namespace only + * for the source, in order to avoid potential confusion, + * lets prevent "::" in the token too. --dl + */ + + if (strstr(hiddenCmdToken, "::") != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot use namespace qualifiers as hidden command", + "token (rename)", (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the command to hide. An error is returned if cmdName can't + * be found. Look up the command only from the global namespace. + * Full path of the command must be given if using namespaces. + */ + + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, + /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); + if (cmd == (Tcl_Command) NULL) { + return TCL_ERROR; + } + cmdPtr = (Command *) cmd; + + /* + * Check that the command is really in global namespace + */ + + if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can only hide global namespace commands", + " (use rename then hide)", (char *) NULL); + return TCL_ERROR; + } + + /* + * Initialize the hidden command table if necessary. + */ + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", + NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) + ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); + Tcl_SetAssocData(interp, "tclHiddenCmds", HiddenCmdsDeleteProc, + (ClientData) hTblPtr); + } + + /* + * It is an error to move an exposed command to a hidden command with + * hiddenCmdToken if a hidden command with the name hiddenCmdToken already + * exists. + */ + + hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new); + if (!new) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "hidden command named \"", hiddenCmdToken, "\" already exists", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Nb : This code is currently 'like' a rename to a specialy set apart + * name table. Changes here and in TclRenameCommand must + * be kept in synch untill the common parts are actually + * factorized out. + */ + + /* + * Remove the hash entry for the command from the interpreter command + * table. This is like deleting the command, so bump its command epoch; + * this invalidates any cached references that point to the command. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = (Tcl_HashEntry *) NULL; + cmdPtr->cmdEpoch++; + } + + /* + * Now link the hash table entry with the command structure. + * We ensured above that the nsPtr was right. + */ + + cmdPtr->hPtr = hPtr; + Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); + + /* + * If the command being hidden has a compile procedure, increment the + * interpreter's compileEpoch to invalidate its compiled code. This + * makes sure that we don't later try to execute old code compiled with + * command-specific (i.e., inline) bytecodes for the now-hidden + * command. This field is checked in Tcl_EvalObj and ObjInterpProc, + * and code whose compilation epoch doesn't match is recompiled. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExposeCommand -- + * + * Makes a previously hidden command callable from inside the + * interpreter instead of only by its ancestors. + * + * Results: + * A standard Tcl result. If an error occurs, a message is left + * in interp->result. + * + * Side effects: + * Moves commands from one hash table to another. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) + Tcl_Interp *interp; /* Interpreter in which to make command + * callable. */ + char *hiddenCmdToken; /* Name of hidden command. */ + char *cmdName; /* Name of to-be-exposed command. */ +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr; + Namespace *nsPtr; + Tcl_HashEntry *hPtr; + Tcl_HashTable *hTblPtr; + int new; + + if (iPtr->flags & DELETED) { + /* + * The interpreter is being deleted. Do not create any new + * structures, because it is not safe to modify the interpreter. + */ + + return TCL_ERROR; + } + + /* + * Check that we have a regular name for the command + * (that the user is not trying to do an expose and a rename + * (to another namespace) at the same time) + */ + + if (strstr(cmdName, "::") != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can not expose to a namespace ", + "(use expose to toplevel, then rename)", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the hash table for the hidden commands; error out if there + * is none. + */ + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", + NULL); + if (hTblPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown hidden command \"", hiddenCmdToken, + "\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Get the command from the hidden command table: + */ + + hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown hidden command \"", hiddenCmdToken, + "\"", (char *) NULL); + return TCL_ERROR; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + + /* + * Check that we have a true global namespace + * command (enforced by Tcl_HideCommand() but let's double + * check. (If it was not, we would not really know how to + * handle it). + */ + if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { + /* + * This case is theoritically impossible, + * we might rather panic() than 'nicely' erroring out ? + */ + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "trying to expose a non global command name space command", + (char *) NULL); + return TCL_ERROR; + } + + /* This is the global table */ + nsPtr = cmdPtr->nsPtr; + + /* + * It is an error to overwrite an existing exposed command as a result + * of exposing a previously hidden command. + */ + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new); + if (!new) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "exposed command \"", cmdName, + "\" already exists", (char *) NULL); + return TCL_ERROR; + } + + /* + * Remove the hash entry for the command from the interpreter hidden + * command table. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + } + + /* + * Now link the hash table entry with the command structure. + * This is like creating a new command, so deal with any shadowing + * of commands in the global namespace. + */ + + cmdPtr->hPtr = hPtr; + + Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); + + /* + * Not needed as we are only in the global namespace + * (but would be needed again if we supported namespace command hiding) + * + * TclResetShadowedCmdRefs(interp, cmdPtr); + */ + + + /* + * If the command being exposed has a compile procedure, increment + * interpreter's compileEpoch to invalidate its compiled code. This + * makes sure that we don't later try to execute old code compiled + * assuming the command is hidden. This field is checked in Tcl_EvalObj + * and ObjInterpProc, and code whose compilation epoch doesn't match is + * recompiled. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateCommand -- + * + * Define a new command in a command table. + * + * Results: + * The return value is a token for the command, which can + * be used in future calls to Tcl_GetCommandName. + * + * Side effects: + * If a command named cmdName already exists for interp, it is deleted. + * In the future, when cmdName is seen as the name of a command by + * Tcl_Eval, proc will be called. To support the bytecode interpreter, + * the command is created with a wrapper Tcl_ObjCmdProc + * (TclInvokeStringCommand) that eventially calls proc. When the + * command is deleted from the table, deleteProc will be called. + * See the manual entry for details on the calling sequence. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) + Tcl_Interp *interp; /* Token for command interpreter returned by + * a previous call to Tcl_CreateInterp. */ + char *cmdName; /* Name of command. If it contains namespace + * qualifiers, the new command is put in the + * specified namespace; otherwise it is put + * in the global namespace. */ + Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */ + ClientData clientData; /* Arbitrary value passed to string proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* If not NULL, gives a procedure to call + * when this command is deleted. */ +{ + Interp *iPtr = (Interp *) interp; + ImportRef *oldRefPtr = NULL; + Namespace *nsPtr, *dummy1, *dummy2; + Command *cmdPtr, *refCmdPtr; + Tcl_HashEntry *hPtr; + char *tail; + int new, result; + ImportedCmdData *dataPtr; + + if (iPtr->flags & DELETED) { + /* + * The interpreter is being deleted. Don't create any new + * commands; it's not safe to muck with the interpreter anymore. + */ + + return (Tcl_Command) NULL; + } + + /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; + * otherwise, we always put it in the global namespace. + */ + + if (strstr(cmdName, "::") != NULL) { + result = TclGetNamespaceForQualName(interp, cmdName, + (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr, + &dummy1, &dummy2, &tail); + if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { + /* + * Command already exists. Delete the old one. + * Be careful to preserve any existing import links so we can + * restore them down below. That way, you can redefine a + * command and its import status will remain intact. + */ + + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { + /* + * If the deletion callback recreated the command, just throw + * away the new command (if we try to delete it again, we + * could get stuck in an infinite loop). + */ + + ckfree((char*) cmdPtr); + } + } + cmdPtr = (Command *) ckalloc(sizeof(Command)); + Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = nsPtr; + cmdPtr->refCount = 1; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = (CompileProc *) NULL; + cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objClientData = (ClientData) cmdPtr; + cmdPtr->proc = proc; + cmdPtr->clientData = clientData; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; + cmdPtr->deleted = 0; + cmdPtr->importRefPtr = NULL; + + /* + * Plug in any existing import references found above. Be sure + * to update all of these references to point to the new command. + */ + + if (oldRefPtr != NULL) { + cmdPtr->importRefPtr = oldRefPtr; + while (oldRefPtr != NULL) { + refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; + dataPtr->realCmdPtr = cmdPtr; + oldRefPtr = oldRefPtr->nextPtr; + } + } + + /* + * We just created a command, so in its namespace and all of its parent + * namespaces, it may shadow global commands with the same name. If any + * shadowed commands are found, invalidate all cached command references + * in the affected namespaces. + */ + + TclResetShadowedCmdRefs(interp, cmdPtr); + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateObjCommand -- + * + * Define a new object-based command in a command table. + * + * Results: + * The return value is a token for the command, which can + * be used in future calls to Tcl_NameOfCommand. + * + * Side effects: + * If no command named "cmdName" already exists for interp, one is + * created. Otherwise, if a command does exist, then if the + * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume + * Tcl_CreateCommand was called previously for the same command and + * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we + * delete the old command. + * + * In the future, during bytecode evaluation when "cmdName" is seen as + * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based + * Tcl_ObjCmdProc proc will be called. When the command is deleted from + * the table, deleteProc will be called. See the manual entry for + * details on the calling sequence. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by previous call to Tcl_CreateInterp). */ + char *cmdName; /* Name of command. If it contains namespace + * qualifiers, the new command is put in the + * specified namespace; otherwise it is put + * in the global namespace. */ + Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with + * name. */ + ClientData clientData; /* Arbitrary value to pass to object + * procedure. */ + Tcl_CmdDeleteProc *deleteProc; + /* If not NULL, gives a procedure to call + * when this command is deleted. */ +{ + Interp *iPtr = (Interp *) interp; + ImportRef *oldRefPtr = NULL; + Namespace *nsPtr, *dummy1, *dummy2; + Command *cmdPtr, *refCmdPtr; + Tcl_HashEntry *hPtr; + char *tail; + int new, result; + ImportedCmdData *dataPtr; + + if (iPtr->flags & DELETED) { + /* + * The interpreter is being deleted. Don't create any new + * commands; it's not safe to muck with the interpreter anymore. + */ + + return (Tcl_Command) NULL; + } + + /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; + * otherwise, we always put it in the global namespace. + */ + + if (strstr(cmdName, "::") != NULL) { + result = TclGetNamespaceForQualName(interp, cmdName, + (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr, + &dummy1, &dummy2, &tail); + if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + /* + * Command already exists. If its object-based Tcl_ObjCmdProc is + * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the + * argument "proc". Otherwise, we delete the old command. + */ + + if (cmdPtr->objProc == TclInvokeStringCommand) { + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; + return (Tcl_Command) cmdPtr; + } + + /* + * Otherwise, we delete the old command. Be careful to preserve + * any existing import links so we can restore them down below. + * That way, you can redefine a command and its import status + * will remain intact. + */ + + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { + /* + * If the deletion callback recreated the command, just throw + * away the new command (if we try to delete it again, we + * could get stuck in an infinite loop). + */ + + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + } + cmdPtr = (Command *) ckalloc(sizeof(Command)); + Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = nsPtr; + cmdPtr->refCount = 1; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = (CompileProc *) NULL; + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->clientData = (ClientData) cmdPtr; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; + cmdPtr->deleted = 0; + cmdPtr->importRefPtr = NULL; + + /* + * Plug in any existing import references found above. Be sure + * to update all of these references to point to the new command. + */ + + if (oldRefPtr != NULL) { + cmdPtr->importRefPtr = oldRefPtr; + while (oldRefPtr != NULL) { + refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; + dataPtr->realCmdPtr = cmdPtr; + oldRefPtr = oldRefPtr->nextPtr; + } + } + + /* + * We just created a command, so in its namespace and all of its parent + * namespaces, it may shadow global commands with the same name. If any + * shadowed commands are found, invalidate all cached command references + * in the affected namespaces. + */ + + TclResetShadowedCmdRefs(interp, cmdPtr); + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclInvokeStringCommand -- + * + * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based + * Tcl_CmdProc if no object-based procedure exists for a command. A + * pointer to this procedure is stored as the Tcl_ObjCmdProc in a + * Command structure. It simply turns around and calls the string + * Tcl_CmdProc in the Command structure. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * Besides those side effects of the called Tcl_CmdProc, + * TclInvokeStringCommand allocates and frees storage. + * + *---------------------------------------------------------------------- + */ + +int +TclInvokeStringCommand(clientData, interp, objc, objv) + ClientData clientData; /* Points to command's Command structure. */ + Tcl_Interp *interp; /* Current interpreter. */ + register int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Command *cmdPtr = (Command *) clientData; + register int i; + int result; + + /* + * This procedure generates an argv array for the string arguments. It + * starts out with stack-allocated space but uses dynamically-allocated + * storage if needed. + */ + +#define NUM_ARGS 20 + char *(argStorage[NUM_ARGS]); + char **argv = argStorage; + + /* + * Create the string argument array "argv". Make sure argv is large + * enough to hold the objc arguments plus 1 extra for the zero + * end-of-argv word. + * THIS FAILS IF ANY ARGUMENT OBJECT CONTAINS AN EMBEDDED NULL. + */ + + if ((objc + 1) > NUM_ARGS) { + argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); + } + + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetStringFromObj(objv[i], (int *) NULL); + } + argv[objc] = 0; + + /* + * Invoke the command's string-based Tcl_CmdProc. + */ + + result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); + + /* + * Free the argv array if malloc'ed storage was used. + */ + + if (argv != argStorage) { + ckfree((char *) argv); + } + return result; +#undef NUM_ARGS +} + +/* + *---------------------------------------------------------------------- + * + * TclInvokeObjectCommand -- + * + * "Wrapper" Tcl_CmdProc used to call an existing object-based + * Tcl_ObjCmdProc if no string-based procedure exists for a command. + * A pointer to this procedure is stored as the Tcl_CmdProc in a + * Command structure. It simply turns around and calls the object + * Tcl_ObjCmdProc in the Command structure. + * + * Results: + * A standard Tcl string result value. + * + * Side effects: + * Besides those side effects of the called Tcl_CmdProc, + * TclInvokeStringCommand allocates and frees storage. + * + *---------------------------------------------------------------------- + */ + +int +TclInvokeObjectCommand(clientData, interp, argc, argv) + ClientData clientData; /* Points to command's Command structure. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + register char **argv; /* Argument strings. */ +{ + Command *cmdPtr = (Command *) clientData; + register Tcl_Obj *objPtr; + register int i; + int length, result; + + /* + * This procedure generates an objv array for object arguments that hold + * the argv strings. It starts out with stack-allocated space but uses + * dynamically-allocated storage if needed. + */ + +#define NUM_ARGS 20 + Tcl_Obj *(argStorage[NUM_ARGS]); + register Tcl_Obj **objv = argStorage; + + /* + * Create the object argument array "objv". Make sure objv is large + * enough to hold the objc arguments plus 1 extra for the zero + * end-of-objv word. + */ + + if ((argc + 1) > NUM_ARGS) { + objv = (Tcl_Obj **) + ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); + } + + for (i = 0; i < argc; i++) { + length = strlen(argv[i]); + TclNewObj(objPtr); + TclInitStringRep(objPtr, argv[i], length); + Tcl_IncrRefCount(objPtr); + objv[i] = objPtr; + } + objv[argc] = 0; + + /* + * Invoke the command's object-based Tcl_ObjCmdProc. + */ + + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); + + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULL BYTES. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + + /* + * Decrement the ref counts for the argument objects created above, + * then free the objv array if malloc'ed storage was used. + */ + + for (i = 0; i < argc; i++) { + objPtr = objv[i]; + Tcl_DecrRefCount(objPtr); + } + if (objv != argStorage) { + ckfree((char *) objv); + } + return result; +#undef NUM_ARGS +} + +/* + *---------------------------------------------------------------------- + * + * TclRenameCommand -- + * + * Called to give an existing Tcl command a different name. Both the + * old command name and the new command name can have "::" namespace + * qualifiers. If the new command has a different namespace context, + * the command will be moved to that namespace and will execute in + * the context of that new namespace. + * + * If the new command name is NULL or the null string, the command is + * deleted. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, an error message is returned in the + * interpreter's result object. + * + *---------------------------------------------------------------------- + */ + +int +TclRenameCommand(interp, oldName, newName) + Tcl_Interp *interp; /* Current interpreter. */ + char *oldName; /* Existing command name. */ + char *newName; /* New command name. */ +{ + Interp *iPtr = (Interp *) interp; + char *newTail; + Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; + Tcl_Command cmd; + Command *cmdPtr; + Tcl_HashEntry *hPtr, *oldHPtr; + int new, result; + + /* + * Find the existing command. An error is returned if cmdName can't + * be found. + */ + + cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL, + /*flags*/ 0); + cmdPtr = (Command *) cmd; + if (cmdPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ", + ((newName == NULL)||(*newName == '\0'))? "delete":"rename", + " \"", oldName, "\": command doesn't exist", (char *) NULL); + return TCL_ERROR; + } + cmdNsPtr = cmdPtr->nsPtr; + + /* + * If the new command name is NULL or empty, delete the command. Do this + * with Tcl_DeleteCommandFromToken, since we already have the command. + */ + + if ((newName == NULL) || (*newName == '\0')) { + Tcl_DeleteCommandFromToken(interp, cmd); + return TCL_OK; + } + + /* + * Make sure that the destination command does not already exist. + * The rename operation is like creating a command, so we should + * automatically create the containing namespaces just like + * Tcl_CreateCommand would. + */ + + result = TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, + (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), + &newNsPtr, &dummy1, &dummy2, &newTail); + if (result != TCL_OK) { + return result; + } + if ((newNsPtr == NULL) || (newTail == NULL)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't rename to \"", newName, "\": bad command name", + (char *) NULL); + return TCL_ERROR; + } + if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't rename to \"", newName, + "\": command already exists", (char *) NULL); + return TCL_ERROR; + } + + + /* + * Warning: any changes done in the code here are likely + * to be needed in Tcl_HideCommand() code too. + * (until the common parts are extracted out) --dl + */ + + /* + * Put the command in the new namespace so we can check for an alias + * loop. Since we are adding a new command to a namespace, we must + * handle any shadowing of the global commands that this might create. + */ + + oldHPtr = cmdPtr->hPtr; + hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new); + Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = newNsPtr; + TclResetShadowedCmdRefs(interp, cmdPtr); + + /* + * Now check for an alias loop. If we detect one, put everything back + * the way it was and report the error. + */ + + result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); + if (result != TCL_OK) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = oldHPtr; + cmdPtr->nsPtr = cmdNsPtr; + return result; + } + + /* + * The new command name is okay, so remove the command from its + * current namespace. This is like deleting the command, so bump + * the cmdEpoch to invalidate any cached references to the command. + */ + + Tcl_DeleteHashEntry(oldHPtr); + cmdPtr->cmdEpoch++; + + /* + * If the command being renamed has a compile procedure, increment the + * interpreter's compileEpoch to invalidate its compiled code. This + * makes sure that we don't later try to execute old code compiled for + * the now-renamed command. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCommandInfo -- + * + * Modifies various information about a Tcl command. Note that + * this procedure will not change a command's namespace; use + * Tcl_RenameCommand to do that. Also, the isNativeObjectProc + * member of *infoPtr is ignored. + * + * Results: + * If cmdName exists in interp, then the information at *infoPtr + * is stored with the command in place of the current information + * and 1 is returned. If the command doesn't exist then 0 is + * returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetCommandInfo(interp, cmdName, infoPtr) + Tcl_Interp *interp; /* Interpreter in which to look + * for command. */ + char *cmdName; /* Name of desired command. */ + Tcl_CmdInfo *infoPtr; /* Where to store information about + * command. */ +{ + Tcl_Command cmd; + Command *cmdPtr; + + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, + /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { + return 0; + } + + /* + * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. + */ + + cmdPtr = (Command *) cmd; + cmdPtr->proc = infoPtr->proc; + cmdPtr->clientData = infoPtr->clientData; + if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { + cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objClientData = (ClientData) cmdPtr; + } else { + cmdPtr->objProc = infoPtr->objProc; + cmdPtr->objClientData = infoPtr->objClientData; + } + cmdPtr->deleteProc = infoPtr->deleteProc; + cmdPtr->deleteData = infoPtr->deleteData; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandInfo -- + * + * Returns various information about a Tcl command. + * + * Results: + * If cmdName exists in interp, then *infoPtr is modified to + * hold information about cmdName and 1 is returned. If the + * command doesn't exist then 0 is returned and *infoPtr isn't + * modified. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetCommandInfo(interp, cmdName, infoPtr) + Tcl_Interp *interp; /* Interpreter in which to look + * for command. */ + char *cmdName; /* Name of desired command. */ + Tcl_CmdInfo *infoPtr; /* Where to store information about + * command. */ +{ + Tcl_Command cmd; + Command *cmdPtr; + + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, + /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { + return 0; + } + + /* + * Set isNativeObjectProc 1 if objProc was registered by a call to + * Tcl_CreateObjCommand. Otherwise set it to 0. + */ + + cmdPtr = (Command *) cmd; + infoPtr->isNativeObjectProc = + (cmdPtr->objProc != TclInvokeStringCommand); + infoPtr->objProc = cmdPtr->objProc; + infoPtr->objClientData = cmdPtr->objClientData; + infoPtr->proc = cmdPtr->proc; + infoPtr->clientData = cmdPtr->clientData; + infoPtr->deleteProc = cmdPtr->deleteProc; + infoPtr->deleteData = cmdPtr->deleteData; + infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandName -- + * + * Given a token returned by Tcl_CreateCommand, this procedure + * returns the current name of the command (which may have changed + * due to renaming). + * + * Results: + * The return value is the name of the given command. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetCommandName(interp, command) + Tcl_Interp *interp; /* Interpreter containing the command. */ + Tcl_Command command; /* Token for command returned by a previous + * call to Tcl_CreateCommand. The command + * must not have been deleted. */ +{ + Command *cmdPtr = (Command *) command; + + if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { + + /* + * This should only happen if command was "created" after the + * interpreter began to be deleted, so there isn't really any + * command. Just return an empty string. + */ + + return ""; + } + return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandFullName -- + * + * Given a token returned by, e.g., Tcl_CreateCommand or + * Tcl_FindCommand, this procedure appends to an object the command's + * full name, qualified by a sequence of parent namespace names. The + * command's fully-qualified name may have changed due to renaming. + * + * Results: + * None. + * + * Side effects: + * The command's fully-qualified name is appended to the string + * representation of objPtr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_GetCommandFullName(interp, command, objPtr) + Tcl_Interp *interp; /* Interpreter containing the command. */ + Tcl_Command command; /* Token for command returned by a previous + * call to Tcl_CreateCommand. The command + * must not have been deleted. */ + Tcl_Obj *objPtr; /* Points to the object onto which the + * command's full name is appended. */ + +{ + Interp *iPtr = (Interp *) interp; + register Command *cmdPtr = (Command *) command; + char *name; + + /* + * Add the full name of the containing namespace, followed by the "::" + * separator, and the command name. + */ + + if (cmdPtr != NULL) { + if (cmdPtr->nsPtr != NULL) { + Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); + if (cmdPtr->nsPtr != iPtr->globalNsPtr) { + Tcl_AppendToObj(objPtr, "::", 2); + } + } + if (cmdPtr->hPtr != NULL) { + name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); + Tcl_AppendToObj(objPtr, name, -1); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCommand -- + * + * Remove the given command from the given interpreter. + * + * Results: + * 0 is returned if the command was deleted successfully. + * -1 is returned if there didn't exist a command by that name. + * + * Side effects: + * cmdName will no longer be recognized as a valid command for + * interp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DeleteCommand(interp, cmdName) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous Tcl_CreateInterp call). */ + char *cmdName; /* Name of command to remove. */ +{ + Tcl_Command cmd; + + /* + * Find the desired command and delete it. + */ + + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, + /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { + return -1; + } + return Tcl_DeleteCommandFromToken(interp, cmd); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCommandFromToken -- + * + * Removes the given command from the given interpreter. This procedure + * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead + * of a command name for efficiency. + * + * Results: + * 0 is returned if the command was deleted successfully. + * -1 is returned if there didn't exist a command by that name. + * + * Side effects: + * The command specified by "cmd" will no longer be recognized as a + * valid command for "interp". + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DeleteCommandFromToken(interp, cmd) + Tcl_Interp *interp; /* Token for command interpreter returned by + * a previous call to Tcl_CreateInterp. */ + Tcl_Command cmd; /* Token for command to delete. */ +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr = (Command *) cmd; + ImportRef *refPtr, *nextRefPtr; + Tcl_Command importCmd; + + /* + * The code here is tricky. We can't delete the hash table entry + * before invoking the deletion callback because there are cases + * where the deletion callback needs to invoke the command (e.g. + * object systems such as OTcl). However, this means that the + * callback could try to delete or rename the command. The deleted + * flag allows us to detect these cases and skip nested deletes. + */ + + if (cmdPtr->deleted) { + /* + * Another deletion is already in progress. Remove the hash + * table entry now, but don't invoke a callback or free the + * command structure. + */ + + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + return 0; + } + + /* + * If the command being deleted has a compile procedure, increment the + * interpreter's compileEpoch to invalidate its compiled code. This + * makes sure that we don't later try to execute old code compiled with + * command-specific (i.e., inline) bytecodes for the now-deleted + * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and + * code whose compilation epoch doesn't match is recompiled. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + + cmdPtr->deleted = 1; + if (cmdPtr->deleteProc != NULL) { + /* + * Delete the command's client data. If this was an imported command + * created when a command was imported into a namespace, this client + * data will be a pointer to a ImportedCmdData structure describing + * the "real" command that this imported command refers to. + */ + + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + + /* + * If this command was imported into other namespaces, then imported + * commands were created that refer back to this command. Delete these + * imported commands now. + */ + + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; + refPtr = nextRefPtr) { + nextRefPtr = refPtr->nextPtr; + importCmd = (Tcl_Command) refPtr->importedCmdPtr; + Tcl_DeleteCommandFromToken(interp, importCmd); + } + + /* + * Don't use hPtr to delete the hash entry here, because it's + * possible that the deletion callback renamed the command. + * Instead, use cmdPtr->hptr, and make sure that no-one else + * has already deleted the hash entry. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + } + + /* + * Mark the Command structure as no longer valid. This allows + * TclExecuteByteCode to recognize when a Command has logically been + * deleted and a pointer to this Command structure cached in a CmdName + * object is invalid. TclExecuteByteCode will look up the command again + * in the interpreter's command hashtable. + */ + + cmdPtr->objProc = NULL; + + /* + * Now free the Command structure, unless there is another reference to + * it from a CmdName Tcl object in some ByteCode code sequence. In that + * case, delay the cleanup until all references are either discarded + * (when a ByteCode is freed) or replaced by a new reference (when a + * cached CmdName Command reference is found to be invalid and + * TclExecuteByteCode looks up the command in the command hashtable). + */ + + TclCleanupCommand(cmdPtr); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclCleanupCommand -- + * + * This procedure frees up a Command structure unless it is still + * referenced from an interpreter's command hashtable or from a CmdName + * Tcl object representing the name of a command in a ByteCode + * instruction sequence. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed unless a reference to the Command structure still + * exists. In that case the cleanup is delayed until the command is + * deleted or when the last ByteCode referring to it is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclCleanupCommand(cmdPtr) + register Command *cmdPtr; /* Points to the Command structure to + * be freed. */ +{ + cmdPtr->refCount--; + if (cmdPtr->refCount <= 0) { + ckfree((char *) cmdPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Eval -- + * + * Execute a Tcl command in a string. + * + * Results: + * The return value is one of the return codes defined in tcl.h + * (such as TCL_OK), and interp->result contains a string value + * to supplement the return code. The value of interp->result + * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: + * you must copy it or lose it! + * + * Side effects: + * The string is compiled to produce a ByteCode object that holds the + * command's bytecode instructions. However, this ByteCode object is + * lost after executing the command. The command's execution will + * almost certainly have side effects. interp->termOffset is set to the + * offset of the character in "string" just after the last one + * successfully compiled or executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Eval(interp, string) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by previous call to Tcl_CreateInterp). */ + char *string; /* Pointer to TCL command to execute. */ +{ + register Tcl_Obj *cmdPtr; + int length = strlen(string); + int result; + + if (length > 0) { + /* + * Initialize a Tcl object from the command string. + */ + + TclNewObj(cmdPtr); + TclInitStringRep(cmdPtr, string, length); + Tcl_IncrRefCount(cmdPtr); + + /* + * Compile and execute the bytecodes. + */ + + result = Tcl_EvalObj(interp, cmdPtr); + + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + + /* + * Discard the Tcl object created to hold the command and its code. + */ + + Tcl_DecrRefCount(cmdPtr); + } else { + /* + * An empty string. Just reset the interpreter's result. + */ + + Tcl_ResetResult(interp); + result = TCL_OK; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObj -- + * + * Execute Tcl commands stored in a Tcl object. These commands are + * compiled into bytecodes if necessary. + * + * Results: + * The return value is one of the return codes defined in tcl.h + * (such as TCL_OK), and the interpreter's result contains a value + * to supplement the return code. + * + * Side effects: + * The object is converted, if necessary, to a ByteCode object that + * holds the bytecode instructions for the commands. Executing the + * commands will almost certainly have side effects that depend + * on those commands. + * + * Just as in Tcl_Eval, interp->termOffset is set to the offset of the + * last character executed in the objPtr's string. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_EvalObj + +int +Tcl_EvalObj(interp, objPtr) + Tcl_Interp *interp; /* Token for command interpreter + * (returned by a previous call to + * Tcl_CreateInterp). */ + Tcl_Obj *objPtr; /* Pointer to object containing + * commands to execute. */ +{ + register Interp *iPtr = (Interp *) interp; + int flags; /* Interp->evalFlags value when the + * procedure was called. */ + register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ + int oldCount = iPtr->cmdCount; /* Used to tell whether any commands + * at all were executed. */ + int numSrcChars; + register int result; + Namespace *namespacePtr; + + /* + * Reset both the interpreter's string and object results and clear out + * any error information. This makes sure that we return an empty + * result if there are no commands in the command string. + */ + + Tcl_ResetResult(interp); + + /* + * Check depth of nested calls to Tcl_Eval: if this gets too large, + * it's probably because of an infinite loop somewhere. + */ + + iPtr->numLevels++; + if (iPtr->numLevels > iPtr->maxNestingDepth) { + iPtr->numLevels--; + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); + return TCL_ERROR; + } + + /* + * On the Mac, we will never reach the default recursion limit before blowing + * the stack. So we need to do a check here. + */ + + if (TclpCheckStackSpace() == 0) { + /*NOTREACHED*/ + iPtr->numLevels--; + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); + return TCL_ERROR; + } + + /* + * If the interpreter has been deleted, return an error. + */ + + if (iPtr->flags & DELETED) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "attempt to call eval in deleted interpreter", -1); + Tcl_SetErrorCode(interp, "CORE", "IDELETE", + "attempt to call eval in deleted interpreter", (char *) NULL); + iPtr->numLevels--; + return TCL_ERROR; + } + + /* + * Get the ByteCode from the object. If it exists, make sure it hasn't + * been invalidated by, e.g., someone redefining a command with a + * compile procedure (this might make the compiled code wrong). If + * necessary, convert the object to be a ByteCode object and compile it. + * Also, if the code was compiled in/for a different interpreter, + * or for a different namespace, or for the same namespace but + * with different name resolution rules, we recompile it. + * + * Precompiled objects, however, are immutable and therefore + * they are not recompiled, even if the epoch has changed. + */ + + if (iPtr->varFramePtr != NULL) { + namespacePtr = iPtr->varFramePtr->nsPtr; + } else { + namespacePtr = iPtr->globalNsPtr; + } + + if (objPtr->typePtr == &tclByteCodeType) { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + + if ((codePtr->iPtr != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != namespacePtr) + || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if (codePtr->iPtr != iPtr) { + panic("Tcl_EvalObj: compiled script jumped interps"); + } + codePtr->compileEpoch = iPtr->compileEpoch; + } else { + tclByteCodeType.freeIntRepProc(objPtr); + } + } + } + if (objPtr->typePtr != &tclByteCodeType) { + /* + * First reset any error line number information. + */ + + iPtr->errorLine = 1; /* no correct line # information yet */ + result = tclByteCodeType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + iPtr->numLevels--; + return result; + } + } + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + + /* + * Extract then reset the compilation flags in the interpreter. + * Resetting the flags must be done after any compilation. + */ + + flags = iPtr->evalFlags; + iPtr->evalFlags = 0; + + /* + * Execute the commands. If the code was compiled from an empty string, + * don't bother executing the code. + */ + + numSrcChars = codePtr->numSrcChars; + if ((numSrcChars > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + /* + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. + */ + + codePtr->refCount++; + result = TclExecuteByteCode(interp, codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + } else { + Tcl_ResetResult(interp); + result = TCL_OK; + } + + /* + * If no commands at all were executed, check for asynchronous + * handlers so that they at least get one change to execute. + * This is needed to handle event loops written in Tcl with + * empty bodies. + */ + + if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) { + result = Tcl_AsyncInvoke(interp, result); + } + + /* + * Free up any extra resources that were allocated. + */ + + iPtr->numLevels--; + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR) + && !(flags & TCL_ALLOW_EXCEPTIONS)) { + Tcl_ResetResult(interp); + if (result == TCL_BREAK) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"break\" outside of a loop", -1); + } else if (result == TCL_CONTINUE) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"continue\" outside of a loop", -1); + } else { + char buf[50]; + sprintf(buf, "command returned bad code: %d", result); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + } + result = TCL_ERROR; + } + } + + /* + * If an error occurred, record information about what was being + * executed when the error occurred. + */ + + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + char buf[200]; + char *ellipsis = ""; + char *bytes; + int length; + + /* + * Figure out how much of the command to print in the error + * message (up to a certain number of characters, or up to + * the first new-line). + * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL. + */ + + bytes = Tcl_GetStringFromObj(objPtr, &length); + length = TclMin(numSrcChars, length); + if (length > 150) { + length = 150; + ellipsis = " ..."; + } + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(buf, "\n while executing\n\"%.*s%s\"", + length, bytes, ellipsis); + } else { + sprintf(buf, "\n invoked from within\n\"%.*s%s\"", + length, bytes, ellipsis); + } + Tcl_AddObjErrorInfo(interp, buf, -1); + } + + /* + * Set the interpreter's termOffset member to the offset of the + * character just after the last one executed. We approximate the offset + * of the last character executed by using the number of characters + * compiled. + */ + + iPtr->termOffset = numSrcChars; + iPtr->flags &= ~ERR_ALREADY_LOGGED; + return result; +} + +/* + *-------------------------------------------------------------- + * + * 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 *ptr. 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. */ +{ + register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); + int result = TCL_OK; + + if (length > 0) { + exprPtr = Tcl_NewStringObj(string, length); + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Store an integer based on the expression result. + */ + + if (resultPtr->typePtr == &tclIntType) { + *ptr = resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (long) resultPtr->internalRep.doubleValue; + } else { + Tcl_SetResult(interp, + "expression didn't have numeric value", TCL_STATIC); + result = TCL_ERROR; + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } else { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), + (int *) NULL), + TCL_VOLATILE); + } + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { + /* + * An empty string. Just set the result integer to 0. + */ + + *ptr = 0; + } + 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. */ +{ + register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); + int result = TCL_OK; + + if (length > 0) { + exprPtr = Tcl_NewStringObj(string, length); + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Store a double based on the expression result. + */ + + if (resultPtr->typePtr == &tclIntType) { + *ptr = (double) resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = resultPtr->internalRep.doubleValue; + } else { + Tcl_SetResult(interp, + "expression didn't have numeric value", TCL_STATIC); + result = TCL_ERROR; + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } else { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), + (int *) NULL), + TCL_VOLATILE); + } + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { + /* + * An empty string. Just set the result double to 0.0. + */ + + *ptr = 0.0; + } + 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. */ +{ + register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); + int result = TCL_OK; + + if (length > 0) { + exprPtr = Tcl_NewStringObj(string, length); + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Store a boolean based on the expression result. + */ + + if (resultPtr->typePtr == &tclIntType) { + *ptr = (resultPtr->internalRep.longValue != 0); + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (resultPtr->internalRep.doubleValue != 0.0); + } else { + result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } + if (result != TCL_OK) { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), + (int *) NULL), + TCL_VOLATILE); + } + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { + /* + * An empty string. Just set the result boolean to 0 (false). + */ + + *ptr = 0; + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- + * + * Procedures to evaluate an expression in an object and return its + * value in a particular form. + * + * Results: + * Each of the procedures below returns a standard Tcl result + * object. If an error occurs then an error message is left in the + * interpreter's result. Otherwise the value of the expression, in the + * appropriate form, is stored at *ptr. If the expression had a result + * that was incompatible with the desired form then an error is + * returned. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprLongObj(interp, objPtr, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + long *ptr; /* Where to store long result. */ +{ + Tcl_Obj *resultPtr; + int result; + + result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result == TCL_OK) { + if (resultPtr->typePtr == &tclIntType) { + *ptr = resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (long) resultPtr->internalRep.doubleValue; + } else { + result = Tcl_GetLongFromObj(interp, resultPtr, ptr); + if (result != TCL_OK) { + return result; + } + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } + return result; +} + +int +Tcl_ExprDoubleObj(interp, objPtr, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + double *ptr; /* Where to store double result. */ +{ + Tcl_Obj *resultPtr; + int result; + + result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result == TCL_OK) { + if (resultPtr->typePtr == &tclIntType) { + *ptr = (double) resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = resultPtr->internalRep.doubleValue; + } else { + result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); + if (result != TCL_OK) { + return result; + } + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } + return result; +} + +int +Tcl_ExprBooleanObj(interp, objPtr, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + int *ptr; /* Where to store 0/1 result. */ +{ + Tcl_Obj *resultPtr; + int result; + + result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result == TCL_OK) { + if (resultPtr->typePtr == &tclIntType) { + *ptr = (resultPtr->internalRep.longValue != 0); + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (resultPtr->internalRep.doubleValue != 0.0); + } else { + result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); + if (result != TCL_OK) { + return result; + } + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclInvoke -- + * + * Invokes a Tcl command, given an argv/argc, from either the + * exposed or the hidden sets of commands in the given interpreter. + * NOTE: The command is invoked in the current stack frame of + * the interpreter, thus it can modify local variables. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Whatever the command does. + * + *---------------------------------------------------------------------- + */ + +int +TclInvoke(interp, argc, argv, flags) + Tcl_Interp *interp; /* Where to invoke the command. */ + int argc; /* Count of args. */ + register char **argv; /* The arg strings; argv[0] is the name of + * the command to invoke. */ + int flags; /* Combination of flags controlling the + * call: TCL_INVOKE_HIDDEN and + * TCL_INVOKE_NO_UNKNOWN. */ +{ + register Tcl_Obj *objPtr; + register int i; + int length, result; + + /* + * This procedure generates an objv array for object arguments that hold + * the argv strings. It starts out with stack-allocated space but uses + * dynamically-allocated storage if needed. + */ + +#define NUM_ARGS 20 + Tcl_Obj *(objStorage[NUM_ARGS]); + register Tcl_Obj **objv = objStorage; + + /* + * Create the object argument array "objv". Make sure objv is large + * enough to hold the objc arguments plus 1 extra for the zero + * end-of-objv word. + */ + + if ((argc + 1) > NUM_ARGS) { + objv = (Tcl_Obj **) + ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); + } + + for (i = 0; i < argc; i++) { + length = strlen(argv[i]); + objv[i] = Tcl_NewStringObj(argv[i], length); + Tcl_IncrRefCount(objv[i]); + } + objv[argc] = 0; + + /* + * Use TclObjInterpProc to actually invoke the command. + */ + + result = TclObjInvoke(interp, argc, objv, flags); + + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + + /* + * Decrement the ref counts on the objv elements since we are done + * with them. + */ + + for (i = 0; i < argc; i++) { + objPtr = objv[i]; + Tcl_DecrRefCount(objPtr); + } + + /* + * Free the objv array if malloc'ed storage was used. + */ + + if (objv != objStorage) { + ckfree((char *) objv); + } + return result; +#undef NUM_ARGS +} + +/* + *---------------------------------------------------------------------- + * + * TclGlobalInvoke -- + * + * Invokes a Tcl command, given an argv/argc, from either the + * exposed or hidden sets of commands in the given interpreter. + * NOTE: The command is invoked in the global stack frame of + * the interpreter, thus it cannot see any current state on + * the stack for that interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Whatever the command does. + * + *---------------------------------------------------------------------- + */ + +int +TclGlobalInvoke(interp, argc, argv, flags) + Tcl_Interp *interp; /* Where to invoke the command. */ + int argc; /* Count of args. */ + register char **argv; /* The arg strings; argv[0] is the name of + * the command to invoke. */ + int flags; /* Combination of flags controlling the + * call: TCL_INVOKE_HIDDEN and + * TCL_INVOKE_NO_UNKNOWN. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = TclInvoke(interp, argc, argv, flags); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclObjInvokeGlobal -- + * + * Object version: Invokes a Tcl command, given an objv/objc, from + * either the exposed or hidden set of commands in the given + * interpreter. + * NOTE: The command is invoked in the global stack frame of the + * interpreter, thus it cannot see any current state on the + * stack of that interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Whatever the command does. + * + *---------------------------------------------------------------------- + */ + +int +TclObjInvokeGlobal(interp, objc, objv, flags) + Tcl_Interp *interp; /* Interpreter in which command is + * to be invoked. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] + * points to the name of the + * command to invoke. */ + int flags; /* Combination of flags controlling + * the call: TCL_INVOKE_HIDDEN and + * TCL_INVOKE_NO_UNKNOWN. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = TclObjInvoke(interp, objc, objv, flags); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclObjInvoke -- + * + * Invokes a Tcl command, given an objv/objc, from either the + * exposed or the hidden sets of commands in the given interpreter. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * Whatever the command does. + * + *---------------------------------------------------------------------- + */ + +int +TclObjInvoke(interp, objc, objv, flags) + Tcl_Interp *interp; /* Interpreter in which command is + * to be invoked. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] + * points to the name of the + * command to invoke. */ + int flags; /* Combination of flags controlling + * the call: TCL_INVOKE_HIDDEN and + * TCL_INVOKE_NO_UNKNOWN. */ +{ + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + char *cmdName; /* Name of the command from objv[0]. */ + register Tcl_HashEntry *hPtr; + Tcl_Command cmd; + Command *cmdPtr; + int localObjc; /* Used to invoke "unknown" if the */ + Tcl_Obj **localObjv = NULL; /* command is not found. */ + register int i; + int length, result; + char *bytes; + + if (interp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + + if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "illegal argument vector", -1); + return TCL_ERROR; + } + + /* + * THE FOLLOWING CODE FAILS IF THE STRING REP CONTAINS NULLS. + */ + + cmdName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + if (flags & TCL_INVOKE_HIDDEN) { + /* + * Find the table of hidden commands; error out if none. + */ + + hTblPtr = (Tcl_HashTable *) + Tcl_GetAssocData(interp, "tclHiddenCmds", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + badhiddenCmdToken: + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid hidden command name \"", cmdName, "\"", + (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); + + /* + * We never invoke "unknown" for hidden commands. + */ + + if (hPtr == NULL) { + goto badhiddenCmdToken; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + } else { + cmdPtr = NULL; + cmd = Tcl_FindCommand(interp, cmdName, + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + if (cmd != (Tcl_Command) NULL) { + cmdPtr = (Command *) cmd; + } + if (cmdPtr == NULL) { + if (!(flags & TCL_INVOKE_NO_UNKNOWN)) { + cmd = Tcl_FindCommand(interp, "unknown", + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + if (cmd != (Tcl_Command) NULL) { + cmdPtr = (Command *) cmd; + } + if (cmdPtr != NULL) { + localObjc = (objc + 1); + localObjv = (Tcl_Obj **) + ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc)); + localObjv[0] = Tcl_NewStringObj("unknown", -1); + Tcl_IncrRefCount(localObjv[0]); + for (i = 0; i < objc; i++) { + localObjv[i+1] = objv[i]; + } + objc = localObjc; + objv = localObjv; + } + } + + /* + * Check again if we found the command. If not, "unknown" is + * not present and we cannot help, or the caller said not to + * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN). + */ + + if (cmdPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", cmdName, "\"", + (char *) NULL); + return TCL_ERROR; + } + } + } + + /* + * Invoke the command procedure. First reset the interpreter's string + * and object results to their default empty values since they could + * have gotten changed by earlier invocations. + */ + + Tcl_ResetResult(interp); + iPtr->cmdCount++; + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + + /* + * If an error occurred, record information about what was being + * executed when the error occurred. + */ + + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_DString ds; + + Tcl_DStringInit(&ds); + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + Tcl_DStringAppend(&ds, "\n while invoking\n\"", -1); + } else { + Tcl_DStringAppend(&ds, "\n invoked from within\n\"", -1); + } + for (i = 0; i < objc; i++) { + bytes = Tcl_GetStringFromObj(objv[i], &length); + Tcl_DStringAppend(&ds, bytes, length); + if (i < (objc - 1)) { + Tcl_DStringAppend(&ds, " ", -1); + } else if (Tcl_DStringLength(&ds) > 100) { + Tcl_DStringSetLength(&ds, 100); + Tcl_DStringAppend(&ds, "...", -1); + break; + } + } + + Tcl_DStringAppend(&ds, "\"", -1); + Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1); + Tcl_DStringFree(&ds); + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } + + /* + * Free any locally allocated storage used to call "unknown". + */ + + if (localObjv != (Tcl_Obj **) NULL) { + ckfree((char *) localObjv); + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprString -- + * + * Evaluate an expression in a string 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: + * A Tcl object is allocated to hold a copy of the expression string. + * This expression object is passed to Tcl_ExprObj and then + * deallocated. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprString(interp, string) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ +{ + register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); + char buf[100]; + int result = TCL_OK; + + if (length > 0) { + TclNewObj(exprPtr); + TclInitStringRep(exprPtr, string, length); + Tcl_IncrRefCount(exprPtr); + + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Set the interpreter's string result from the result object. + */ + + if (resultPtr->typePtr == &tclIntType) { + sprintf(buf, "%ld", resultPtr->internalRep.longValue); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else if (resultPtr->typePtr == &tclDoubleType) { + Tcl_PrintDouble((Tcl_Interp *) NULL, + resultPtr->internalRep.doubleValue, buf); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else { + /* + * Set interpreter's string result from the result object. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(resultPtr, (int *) NULL), + TCL_VOLATILE); + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } else { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), + (int *) NULL), + TCL_VOLATILE); + } + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { + /* + * An empty string. Just set the interpreter's result to 0. + */ + + Tcl_SetResult(interp, "0", TCL_VOLATILE); + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprObj -- + * + * Evaluate an expression in a Tcl_Obj. + * + * Results: + * A standard Tcl object result. If the result is other than TCL_OK, + * then the interpreter's result contains an error message. If the + * result is TCL_OK, then a pointer to the expression's result value + * object is stored in resultPtrPtr. In that case, the object's ref + * count is incremented to reflect the reference returned to the + * caller; the caller is then responsible for the resulting object + * and must, for example, decrement the ref count when it is finished + * with the object. + * + * Side effects: + * Any side effects caused by subcommands in the expression, if any. + * The interpreter result is not modified unless there is an error. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprObj(interp, objPtr, resultPtrPtr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Points to Tcl object containing + * expression to evaluate. */ + Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression + * result is stored if no errors occur. */ +{ + Interp *iPtr = (Interp *) interp; + CompileEnv compEnv; /* Compilation environment structure + * allocated in frame. */ + register ByteCode *codePtr = NULL; + /* Tcl Internal type of bytecode. + * Initialized to avoid compiler warning. */ + AuxData *auxDataPtr; + Interp dummy; + Tcl_Obj *saveObjPtr; + char *string; + int result; + int i; + + /* + * Get the ByteCode from the object. If it exists, make sure it hasn't + * been invalidated by, e.g., someone redefining a command with a + * compile procedure (this might make the compiled code wrong). If + * necessary, convert the object to be a ByteCode object and compile it. + * Also, if the code was compiled in/for a different interpreter, we + * recompile it. + * + * Precompiled expressions, however, are immutable and therefore + * they are not recompiled, even if the epoch has changed. + * + * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE. + */ + + if (objPtr->typePtr == &tclByteCodeType) { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if ((codePtr->iPtr != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if (codePtr->iPtr != iPtr) { + panic("Tcl_ExprObj: compiled expression jumped interps"); + } + codePtr->compileEpoch = iPtr->compileEpoch; + } else { + tclByteCodeType.freeIntRepProc(objPtr); + objPtr->typePtr = (Tcl_ObjType *) NULL; + } + } + } + if (objPtr->typePtr != &tclByteCodeType) { + int length; + string = Tcl_GetStringFromObj(objPtr, &length); + TclInitCompileEnv(interp, &compEnv, string); + result = TclCompileExpr(interp, string, string + length, + /*flags*/ 0, &compEnv); + if (result == TCL_OK) { + /* + * If the expression yielded no instructions (e.g., was empty), + * push an integer zero object as the expressions's result. + */ + + if (compEnv.codeNext == NULL) { + int objIndex = TclObjIndexForString("0", 0, + /*allocStrRep*/ 0, /*inHeap*/ 0, &compEnv); + Tcl_Obj *objPtr = compEnv.objArrayPtr[objIndex]; + + Tcl_InvalidateStringRep(objPtr); + objPtr->internalRep.longValue = 0; + objPtr->typePtr = &tclIntType; + + TclEmitPush(objIndex, &compEnv); + } + + /* + * Add done instruction at the end of the instruction sequence. + */ + + TclEmitOpcode(INST_DONE, &compEnv); + + TclInitByteCodeObj(objPtr, &compEnv); + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if (tclTraceCompile == 2) { + TclPrintByteCodeObj(interp, objPtr); + } + TclFreeCompileEnv(&compEnv); + } else { + /* + * Compilation errors. Decrement the ref counts on any objects + * in the object array before freeing the compilation + * environment. + */ + + for (i = 0; i < compEnv.objArrayNext; i++) { + Tcl_Obj *elemPtr = compEnv.objArrayPtr[i]; + Tcl_DecrRefCount(elemPtr); + } + + auxDataPtr = compEnv.auxDataArrayPtr; + for (i = 0; i < compEnv.auxDataArrayNext; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + TclFreeCompileEnv(&compEnv); + return result; + } + } + + /* + * Execute the expression after first saving the interpreter's result. + */ + + dummy.objResultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(dummy.objResultPtr); + if (interp->freeProc == 0) { + dummy.freeProc = (Tcl_FreeProc *) 0; + dummy.result = ""; + Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, + TCL_VOLATILE); + } else { + dummy.freeProc = interp->freeProc; + dummy.result = interp->result; + interp->freeProc = (Tcl_FreeProc *) 0; + } + + saveObjPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(saveObjPtr); + + /* + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. + */ + + codePtr->refCount++; + result = TclExecuteByteCode(interp, codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + + /* + * If the expression evaluated successfully, store a pointer to its + * value object in resultPtrPtr then restore the old interpreter result. + * We increment the object's ref count to reflect the reference that we + * are returning to the caller. We also decrement the ref count of the + * interpreter's result object after calling Tcl_SetResult since we + * next store into that field directly. + */ + + if (result == TCL_OK) { + *resultPtrPtr = iPtr->objResultPtr; + Tcl_IncrRefCount(iPtr->objResultPtr); + + Tcl_SetResult(interp, dummy.result, + ((dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc)); + Tcl_DecrRefCount(iPtr->objResultPtr); + iPtr->objResultPtr = saveObjPtr; + } else { + Tcl_DecrRefCount(saveObjPtr); + Tcl_FreeResult((Tcl_Interp *) &dummy); + } + + Tcl_DecrRefCount(dummy.objResultPtr); + dummy.objResultPtr = NULL; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateTrace -- + * + * Arrange for a procedure to be called to trace command execution. + * + * Results: + * The return value is a token for the trace, which may be passed + * to Tcl_DeleteTrace to eliminate the trace. + * + * Side effects: + * From now on, proc will be called just before a command procedure + * is called to execute a Tcl command. Calls to proc will have the + * following form: + * + * void + * proc(clientData, interp, level, command, cmdProc, cmdClientData, + * argc, argv) + * ClientData clientData; + * Tcl_Interp *interp; + * int level; + * char *command; + * int (*cmdProc)(); + * ClientData cmdClientData; + * int argc; + * char **argv; + * { + * } + * + * The clientData and interp arguments to proc will be the same + * as the corresponding arguments to this procedure. Level gives + * the nesting level of command interpretation for this interpreter + * (0 corresponds to top level). Command gives the ASCII text of + * the raw command, cmdProc and cmdClientData give the procedure that + * will be called to process the command and the ClientData value it + * will receive, and argc and argv give the arguments to the + * command, after any argument parsing and substitution. Proc + * does not return a value. + * + *---------------------------------------------------------------------- + */ + +Tcl_Trace +Tcl_CreateTrace(interp, level, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which to create trace. */ + int level; /* Only call proc for commands at nesting + * level<=argument level (1=>top level). */ + Tcl_CmdTraceProc *proc; /* Procedure to call before executing each + * command. */ + ClientData clientData; /* Arbitrary value word to pass to proc. */ +{ + register Trace *tracePtr; + register Interp *iPtr = (Interp *) interp; + + /* + * Invalidate existing compiled code for this interpreter and arrange + * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling + * new code, no commands will be compiled inline (i.e., into an inline + * sequence of instructions). We do this because commands that were + * compiled inline will never result in a command trace being called. + */ + + iPtr->compileEpoch++; + iPtr->flags |= DONT_COMPILE_CMDS_INLINE; + + tracePtr = (Trace *) ckalloc(sizeof(Trace)); + tracePtr->level = level; + tracePtr->proc = proc; + tracePtr->clientData = clientData; + tracePtr->nextPtr = iPtr->tracePtr; + iPtr->tracePtr = tracePtr; + + return (Tcl_Trace) tracePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteTrace -- + * + * Remove a trace. + * + * Results: + * None. + * + * Side effects: + * From now on there will be no more calls to the procedure given + * in trace. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteTrace(interp, trace) + Tcl_Interp *interp; /* Interpreter that contains trace. */ + Tcl_Trace trace; /* Token for trace (returned previously by + * Tcl_CreateTrace). */ +{ + register Interp *iPtr = (Interp *) interp; + register Trace *tracePtr = (Trace *) trace; + register Trace *tracePtr2; + + if (iPtr->tracePtr == tracePtr) { + iPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } else { + for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL; + tracePtr2 = tracePtr2->nextPtr) { + if (tracePtr2->nextPtr == tracePtr) { + tracePtr2->nextPtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + break; + } + } + } + + if (iPtr->tracePtr == NULL) { + /* + * When compiling new code, allow commands to be compiled inline. + */ + + iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddErrorInfo -- + * + * Add information to the "errorInfo" variable that describes the + * current error. + * + * Results: + * None. + * + * Side effects: + * The contents of message are added to the "errorInfo" variable. + * If Tcl_Eval has been called since the current value of errorInfo + * was set, errorInfo is cleared before adding the new message. + * If we are just starting to log an error, errorInfo is initialized + * from the error message in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddErrorInfo(interp, message) + Tcl_Interp *interp; /* Interpreter to which error information + * pertains. */ + char *message; /* Message to record. */ +{ + Tcl_AddObjErrorInfo(interp, message, -1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddObjErrorInfo -- + * + * Add information to the "errorInfo" variable that describes the + * current error. This routine differs from Tcl_AddErrorInfo by + * taking a byte pointer and length. + * + * Results: + * None. + * + * Side effects: + * "length" bytes from "message" are added to the "errorInfo" variable. + * If "length" is negative, use bytes up to the first NULL byte. + * If Tcl_EvalObj has been called since the current value of errorInfo + * was set, errorInfo is cleared before adding the new message. + * If we are just starting to log an error, errorInfo is initialized + * from the error message in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddObjErrorInfo(interp, message, length) + Tcl_Interp *interp; /* Interpreter to which error information + * pertains. */ + char *message; /* Points to the first byte of an array of + * bytes of the message. */ + register int length; /* The number of bytes in the message. + * If < 0, then append all bytes up to a + * NULL byte. */ +{ + register Interp *iPtr = (Interp *) interp; + Tcl_Obj *namePtr, *messagePtr; + + /* + * If we are just starting to log an error, errorInfo is initialized + * from the error message in the interpreter's result. + */ + + namePtr = Tcl_NewStringObj("errorInfo", -1); + Tcl_IncrRefCount(namePtr); + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ + iPtr->flags |= ERR_IN_PROGRESS; + + if (iPtr->result[0] == 0) { + (void) Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, + iPtr->objResultPtr, TCL_GLOBAL_ONLY); + } else { /* use the string result */ + Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, + TCL_GLOBAL_ONLY); + } + + /* + * If the errorCode variable wasn't set by the code that generated + * the error, set it to "NONE". + */ + + if (!(iPtr->flags & ERROR_CODE_SET)) { + (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE", + TCL_GLOBAL_ONLY); + } + } + + /* + * Now append "message" to the end of errorInfo. + */ + + if (length != 0) { + messagePtr = Tcl_NewStringObj(message, length); + Tcl_IncrRefCount(messagePtr); + Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr, + (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); + Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ + } + + Tcl_DecrRefCount(namePtr); /* free the name object */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarEval -- + * + * Given a variable number of string arguments, concatenate them + * all together and execute the result as a Tcl command. + * + * Results: + * A standard Tcl return result. An error message or other + * result may be left in interp->result. + * + * Side effects: + * Depends on what was done by the command. + * + *---------------------------------------------------------------------- + */ + /* VARARGS2 */ /* ARGSUSED */ +int +Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + va_list argList; + Tcl_DString buf; + char *string; + Tcl_Interp *interp; + int result; + + /* + * Copy the strings one after the other into a single larger + * string. Use stack-allocated space for small commands, but if + * the command gets too large than call ckalloc to create the + * space. + */ + + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + Tcl_DStringInit(&buf); + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + Tcl_DStringAppend(&buf, string, -1); + } + va_end(argList); + + result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); + Tcl_DStringFree(&buf); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalEval -- + * + * Evaluate a command at global level in an interpreter. + * + * Results: + * A standard Tcl result is returned, and interp->result is + * modified accordingly. + * + * Side effects: + * The command string is executed in interp, and the execution + * is carried out in the variable context of global level (no + * procedures active), just as if an "uplevel #0" command were + * being executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GlobalEval(interp, command) + Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ + char *command; /* Command to evaluate. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = Tcl_Eval(interp, command); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalEvalObj -- + * + * Execute Tcl commands stored in a Tcl object at global level in + * an interpreter. These commands are compiled into bytecodes if + * necessary. + * + * Results: + * A standard Tcl result is returned, and the interpreter's result + * contains a Tcl object value to supplement the return code. + * + * Side effects: + * The object is converted, if necessary, to a ByteCode object that + * holds the bytecode instructions for the commands. Executing the + * commands will almost certainly have side effects that depend on + * those commands. + * + * The commands are executed in interp, and the execution + * is carried out in the variable context of global level (no + * procedures active), just as if an "uplevel #0" command were + * being executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GlobalEvalObj(interp, objPtr) + Tcl_Interp *interp; /* Interpreter in which to evaluate + * commands. */ + Tcl_Obj *objPtr; /* Pointer to object containing commands + * to execute. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = Tcl_EvalObj(interp, objPtr); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetRecursionLimit -- + * + * Set the maximum number of recursive calls that may be active + * for an interpreter at once. + * + * Results: + * The return value is the old limit on nesting for interp. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetRecursionLimit(interp, depth) + Tcl_Interp *interp; /* Interpreter whose nesting limit + * is to be set. */ + int depth; /* New value for maximimum depth. */ +{ + Interp *iPtr = (Interp *) interp; + int old; + + old = iPtr->maxNestingDepth; + if (depth > 0) { + iPtr->maxNestingDepth = depth; + } + return old; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AllowExceptions -- + * + * Sets a flag in an interpreter so that exceptions can occur + * in the next call to Tcl_Eval without them being turned into + * errors. + * + * Results: + * None. + * + * Side effects: + * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's + * evalFlags structure. See the reference documentation for + * more details. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AllowExceptions(interp) + Tcl_Interp *interp; /* Interpreter in which to set flag. */ +{ + Interp *iPtr = (Interp *) interp; + + iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; +} + diff --git a/tcl/generic/tclBinary.c b/tcl/generic/tclBinary.c new file mode 100644 index 00000000000..b059ce83aea --- /dev/null +++ b/tcl/generic/tclBinary.c @@ -0,0 +1,1013 @@ +/* + * tclBinary.c -- + * + * This file contains the implementation of the "binary" Tcl built-in + * command . + * + * Copyright (c) 1997 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. + * + * RCS: @(#) $Id$ + */ + +#include <math.h> +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following constants are used by GetFormatSpec to indicate various + * special conditions in the parsing of a format specifier. + */ + +#define BINARY_ALL -1 /* Use all elements in the argument. */ +#define BINARY_NOCOUNT -2 /* No count was specified in format. */ + +/* + * Prototypes for local procedures defined in this file: + */ + +static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, + char *cmdPtr, int *countPtr)); +static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, + Tcl_Obj *src, char **cursorPtr)); +static Tcl_Obj * ScanNumber _ANSI_ARGS_((char *buffer, int type)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_BinaryObjCmd -- + * + * This procedure implements the "binary" Tcl command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_BinaryObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int arg; /* Index of next argument to consume. */ + int value = 0; /* Current integer value to be packed. + * Initialized to avoid compiler warning. */ + char cmd; /* Current format character. */ + int count; /* Count associated with current format + * character. */ + char *format; /* Pointer to current position in format + * string. */ + char *cursor; /* Current position within result buffer. */ + char *maxPos; /* Greatest position within result buffer that + * cursor has visited.*/ + char *buffer; /* Start of data buffer. */ + char *errorString, *errorValue, *str; + int offset, size, length; + Tcl_Obj *resultPtr; + + static char *subCmds[] = { "format", "scan", (char *) NULL }; + enum { BinaryFormat, BinaryScan } index; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, + (int *) &index) != TCL_OK) { + return TCL_ERROR; + } + + switch (index) { + case BinaryFormat: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); + return TCL_ERROR; + } + /* + * To avoid copying the data, we format the string in two passes. + * The first pass computes the size of the output buffer. The + * second pass places the formatted data into the buffer. + */ + + format = Tcl_GetStringFromObj(objv[2], NULL); + arg = 3; + offset = length = 0; + while (*format != 0) { + if (!GetFormatSpec(&format, &cmd, &count)) { + break; + } + switch (cmd) { + case 'a': + case 'A': + case 'b': + case 'B': + case 'h': + case 'H': + /* + * For string-type specifiers, the count corresponds + * to the number of characters in a single argument. + */ + + if (arg >= objc) { + goto badIndex; + } + if (count == BINARY_ALL) { + (void)Tcl_GetStringFromObj(objv[arg], &count); + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + arg++; + if (cmd == 'a' || cmd == 'A') { + offset += count; + } else if (cmd == 'b' || cmd == 'B') { + offset += (count + 7) / 8; + } else { + offset += (count + 1) / 2; + } + break; + + case 'c': + size = 1; + goto doNumbers; + case 's': + case 'S': + size = 2; + goto doNumbers; + case 'i': + case 'I': + size = 4; + goto doNumbers; + case 'f': + size = sizeof(float); + goto doNumbers; + case 'd': + size = sizeof(double); + doNumbers: + if (arg >= objc) { + goto badIndex; + } + + /* + * For number-type specifiers, the count corresponds + * to the number of elements in the list stored in + * a single argument. If no count is specified, then + * the argument is taken as a single non-list value. + */ + + if (count == BINARY_NOCOUNT) { + arg++; + count = 1; + } else { + int listc; + Tcl_Obj **listv; + if (Tcl_ListObjGetElements(interp, objv[arg++], + &listc, &listv) != TCL_OK) { + return TCL_ERROR; + } + if (count == BINARY_ALL) { + count = listc; + } else if (count > listc) { + errorString = "number of elements in list does not match count"; + goto error; + } + } + offset += count*size; + break; + + case 'x': + if (count == BINARY_ALL) { + errorString = "cannot use \"*\" in format string with \"x\""; + goto error; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + offset += count; + break; + case 'X': + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count > offset) || (count == BINARY_ALL)) { + count = offset; + } + if (offset > length) { + length = offset; + } + offset -= count; + break; + case '@': + if (offset > length) { + length = offset; + } + if (count == BINARY_ALL) { + offset = length; + } else if (count == BINARY_NOCOUNT) { + goto badCount; + } else { + offset = count; + } + break; + default: { + char buf[2]; + + Tcl_ResetResult(interp); + buf[0] = cmd; + buf[1] = '\0'; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad field specifier \"", buf, "\"", NULL); + return TCL_ERROR; + } + } + } + if (offset > length) { + length = offset; + } + if (length == 0) { + return TCL_OK; + } + + /* + * Prepare the result object by preallocating the caclulated + * number of bytes and filling with nulls. + */ + + resultPtr = Tcl_GetObjResult(interp); + Tcl_SetObjLength(resultPtr, length); + buffer = Tcl_GetStringFromObj(resultPtr, NULL); + memset(buffer, 0, (size_t) length); + + /* + * Pack the data into the result object. Note that we can skip + * the error checking during this pass, since we have already + * parsed the string once. + */ + + arg = 3; + format = Tcl_GetStringFromObj(objv[2], NULL); + cursor = buffer; + maxPos = cursor; + while (*format != 0) { + if (!GetFormatSpec(&format, &cmd, &count)) { + break; + } + if ((count == 0) && (cmd != '@')) { + arg++; + continue; + } + switch (cmd) { + case 'a': + case 'A': { + char pad = (char) (cmd == 'a' ? '\0' : ' '); + + str = Tcl_GetStringFromObj(objv[arg++], &length); + + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + if (length >= count) { + memcpy((VOID *) cursor, (VOID *) str, + (size_t) count); + } else { + memcpy((VOID *) cursor, (VOID *) str, + (size_t) length); + memset(cursor+length, pad, + (size_t) (count - length)); + } + cursor += count; + break; + } + case 'b': + case 'B': { + char *last; + + str = Tcl_GetStringFromObj(objv[arg++], &length); + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + last = cursor + ((count + 7) / 8); + if (count > length) { + count = length; + } + value = 0; + errorString = "binary"; + if (cmd == 'B') { + for (offset = 0; offset < count; offset++) { + value <<= 1; + if (str[offset] == '1') { + value |= 1; + } else if (str[offset] != '0') { + errorValue = str; + goto badValue; + } + if (((offset + 1) % 8) == 0) { + *cursor++ = (char)(value & 0xff); + value = 0; + } + } + } else { + for (offset = 0; offset < count; offset++) { + value >>= 1; + if (str[offset] == '1') { + value |= 128; + } else if (str[offset] != '0') { + errorValue = str; + goto badValue; + } + if (!((offset + 1) % 8)) { + *cursor++ = (char)(value & 0xff); + value = 0; + } + } + } + if ((offset % 8) != 0) { + if (cmd == 'B') { + value <<= 8 - (offset % 8); + } else { + value >>= 8 - (offset % 8); + } + *cursor++ = (char)(value & 0xff); + } + while (cursor < last) { + *cursor++ = '\0'; + } + break; + } + case 'h': + case 'H': { + char *last; + int c; + + str = Tcl_GetStringFromObj(objv[arg++], &length); + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + last = cursor + ((count + 1) / 2); + if (count > length) { + count = length; + } + value = 0; + errorString = "hexadecimal"; + if (cmd == 'H') { + for (offset = 0; offset < count; offset++) { + value <<= 4; + c = tolower(((unsigned char *) str)[offset]); + if ((c >= 'a') && (c <= 'f')) { + value |= ((c - 'a' + 10) & 0xf); + } else if ((c >= '0') && (c <= '9')) { + value |= (c - '0') & 0xf; + } else { + errorValue = str; + goto badValue; + } + if (offset % 2) { + *cursor++ = (char) value; + value = 0; + } + } + } else { + for (offset = 0; offset < count; offset++) { + value >>= 4; + c = tolower(((unsigned char *) str)[offset]); + if ((c >= 'a') && (c <= 'f')) { + value |= ((c - 'a' + 10) << 4) & 0xf0; + } else if ((c >= '0') && (c <= '9')) { + value |= ((c - '0') << 4) & 0xf0; + } else { + errorValue = str; + goto badValue; + } + if (offset % 2) { + *cursor++ = (char)(value & 0xff); + value = 0; + } + } + } + if (offset % 2) { + if (cmd == 'H') { + value <<= 4; + } else { + value >>= 4; + } + *cursor++ = (char) value; + } + + while (cursor < last) { + *cursor++ = '\0'; + } + break; + } + case 'c': + case 's': + case 'S': + case 'i': + case 'I': + case 'd': + case 'f': { + int listc, i; + Tcl_Obj **listv; + + if (count == BINARY_NOCOUNT) { + /* + * Note that we are casting away the const-ness of + * objv, but this is safe since we aren't going to + * modify the array. + */ + + listv = (Tcl_Obj**)(objv + arg); + listc = 1; + count = 1; + } else { + Tcl_ListObjGetElements(interp, objv[arg], + &listc, &listv); + if (count == BINARY_ALL) { + count = listc; + } + } + arg++; + for (i = 0; i < count; i++) { + if (FormatNumber(interp, cmd, listv[i], &cursor) + != TCL_OK) { + return TCL_ERROR; + } + } + break; + } + case 'x': + if (count == BINARY_NOCOUNT) { + count = 1; + } + memset(cursor, 0, (size_t) count); + cursor += count; + break; + case 'X': + if (cursor > maxPos) { + maxPos = cursor; + } + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count == BINARY_ALL) + || (count > (cursor - buffer))) { + cursor = buffer; + } else { + cursor -= count; + } + break; + case '@': + if (cursor > maxPos) { + maxPos = cursor; + } + if (count == BINARY_ALL) { + cursor = maxPos; + } else { + cursor = buffer + count; + } + break; + } + } + break; + + case BinaryScan: { + int i; + Tcl_Obj *valuePtr, *elementPtr; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "value formatString ?varName varName ...?"); + return TCL_ERROR; + } + buffer = Tcl_GetStringFromObj(objv[2], &length); + format = Tcl_GetStringFromObj(objv[3], NULL); + cursor = buffer; + arg = 4; + offset = 0; + while (*format != 0) { + if (!GetFormatSpec(&format, &cmd, &count)) { + goto done; + } + switch (cmd) { + case 'a': + case 'A': + if (arg >= objc) { + goto badIndex; + } + if (count == BINARY_ALL) { + count = length - offset; + } else { + if (count == BINARY_NOCOUNT) { + count = 1; + } + if (count > (length - offset)) { + goto done; + } + } + + str = buffer + offset; + size = count; + + /* + * Trim trailing nulls and spaces, if necessary. + */ + + if (cmd == 'A') { + while (size > 0) { + if (str[size-1] != '\0' && str[size-1] != ' ') { + break; + } + size--; + } + } + valuePtr = Tcl_NewStringObj(str, size); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, + valuePtr, + TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + if (resultPtr == NULL) { + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + offset += count; + break; + case 'b': + case 'B': { + char *dest; + + if (arg >= objc) { + goto badIndex; + } + if (count == BINARY_ALL) { + count = (length - offset)*8; + } else { + if (count == BINARY_NOCOUNT) { + count = 1; + } + if (count > (length - offset)*8) { + goto done; + } + } + str = buffer + offset; + valuePtr = Tcl_NewObj(); + Tcl_SetObjLength(valuePtr, count); + dest = Tcl_GetStringFromObj(valuePtr, NULL); + + if (cmd == 'b') { + for (i = 0; i < count; i++) { + if (i % 8) { + value >>= 1; + } else { + value = *str++; + } + *dest++ = (char) ((value & 1) ? '1' : '0'); + } + } else { + for (i = 0; i < count; i++) { + if (i % 8) { + value <<= 1; + } else { + value = *str++; + } + *dest++ = (char) ((value & 0x80) ? '1' : '0'); + } + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, + valuePtr, + TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + if (resultPtr == NULL) { + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + offset += (count + 7 ) / 8; + break; + } + case 'h': + case 'H': { + char *dest; + int i; + static char hexdigit[] = "0123456789abcdef"; + + if (arg >= objc) { + goto badIndex; + } + if (count == BINARY_ALL) { + count = (length - offset)*2; + } else { + if (count == BINARY_NOCOUNT) { + count = 1; + } + if (count > (length - offset)*2) { + goto done; + } + } + str = buffer + offset; + valuePtr = Tcl_NewObj(); + Tcl_SetObjLength(valuePtr, count); + dest = Tcl_GetStringFromObj(valuePtr, NULL); + + if (cmd == 'h') { + for (i = 0; i < count; i++) { + if (i % 2) { + value >>= 4; + } else { + value = *str++; + } + *dest++ = hexdigit[value & 0xf]; + } + } else { + for (i = 0; i < count; i++) { + if (i % 2) { + value <<= 4; + } else { + value = *str++; + } + *dest++ = hexdigit[(value >> 4) & 0xf]; + } + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, + valuePtr, + TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + if (resultPtr == NULL) { + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + offset += (count + 1) / 2; + break; + } + case 'c': + size = 1; + goto scanNumber; + case 's': + case 'S': + size = 2; + goto scanNumber; + case 'i': + case 'I': + size = 4; + goto scanNumber; + case 'f': + size = sizeof(float); + goto scanNumber; + case 'd': + size = sizeof(double); + /* fall through */ + scanNumber: + if (arg >= objc) { + goto badIndex; + } + if (count == BINARY_NOCOUNT) { + if ((length - offset) < size) { + goto done; + } + valuePtr = ScanNumber(buffer+offset, cmd); + offset += size; + } else { + if (count == BINARY_ALL) { + count = (length - offset) / size; + } + if ((length - offset) < (count * size)) { + goto done; + } + valuePtr = Tcl_NewObj(); + str = buffer+offset; + for (i = 0; i < count; i++) { + elementPtr = ScanNumber(str, cmd); + str += size; + Tcl_ListObjAppendElement(NULL, valuePtr, + elementPtr); + } + offset += count*size; + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, + valuePtr, + TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + if (resultPtr == NULL) { + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + break; + case 'x': + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count == BINARY_ALL) + || (count > (length - offset))) { + offset = length; + } else { + offset += count; + } + break; + case 'X': + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count == BINARY_ALL) || (count > offset)) { + offset = 0; + } else { + offset -= count; + } + break; + case '@': + if (count == BINARY_NOCOUNT) { + goto badCount; + } + if ((count == BINARY_ALL) || (count > length)) { + offset = length; + } else { + offset = count; + } + break; + default: { + char buf[2]; + + Tcl_ResetResult(interp); + buf[0] = cmd; + buf[1] = '\0'; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad field specifier \"", buf, "\"", NULL); + return TCL_ERROR; + } + } + } + + /* + * Set the result to the last position of the cursor. + */ + + done: + Tcl_ResetResult(interp); + Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4); + break; + } + } + return TCL_OK; + + badValue: + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString, + " string but got \"", errorValue, "\" instead", NULL); + return TCL_ERROR; + + badCount: + errorString = "missing count for \"@\" field specifier"; + goto error; + + badIndex: + errorString = "not enough arguments for all format specifiers"; + goto error; + + error: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), errorString, -1); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * GetFormatSpec -- + * + * This function parses the format strings used in the binary + * format and scan commands. + * + * Results: + * Moves the formatPtr to the start of the next command. Returns + * the current command character and count in cmdPtr and countPtr. + * The count is set to BINARY_ALL if the count character was '*' + * or BINARY_NOCOUNT if no count was specified. Returns 1 on + * success, or 0 if the string did not have a format specifier. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetFormatSpec(formatPtr, cmdPtr, countPtr) + char **formatPtr; /* Pointer to format string. */ + char *cmdPtr; /* Pointer to location of command char. */ + int *countPtr; /* Pointer to repeat count value. */ +{ + /* + * Skip any leading blanks. + */ + + while (**formatPtr == ' ') { + (*formatPtr)++; + } + + /* + * The string was empty, except for whitespace, so fail. + */ + + if (!(**formatPtr)) { + return 0; + } + + /* + * Extract the command character and any trailing digits or '*'. + */ + + *cmdPtr = **formatPtr; + (*formatPtr)++; + if (**formatPtr == '*') { + (*formatPtr)++; + (*countPtr) = BINARY_ALL; + } else if (isdigit(UCHAR(**formatPtr))) { + (*countPtr) = strtoul(*formatPtr, formatPtr, 10); + } else { + (*countPtr) = BINARY_NOCOUNT; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * FormatNumber -- + * + * This routine is called by Tcl_BinaryObjCmd to format a number + * into a location pointed at by cursor. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Moves the cursor to the next location to be written into. + * + *---------------------------------------------------------------------- + */ + +static int +FormatNumber(interp, type, src, cursorPtr) + Tcl_Interp *interp; /* Current interpreter, used to report + * errors. */ + int type; /* Type of number to format. */ + Tcl_Obj *src; /* Number to format. */ + char **cursorPtr; /* Pointer to index into destination buffer. */ +{ + int value; + double dvalue; + char cmd = (char)type; + + if (cmd == 'd' || cmd == 'f') { + /* + * For floating point types, we need to copy the data using + * memcpy to avoid alignment issues. + */ + + if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { + return TCL_ERROR; + } + if (cmd == 'd') { + memcpy((*cursorPtr), &dvalue, sizeof(double)); + (*cursorPtr) += sizeof(double); + } else { + float fvalue; + + /* + * Because some compilers will generate floating point exceptions + * on an overflow cast (e.g. Borland), we restrict the values + * to the valid range for float. + */ + + if (fabs(dvalue) > (double)FLT_MAX) { + fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX; + } else { + fvalue = (float) dvalue; + } + memcpy((*cursorPtr), &fvalue, sizeof(float)); + (*cursorPtr) += sizeof(float); + } + } else { + if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) { + return TCL_ERROR; + } + if (cmd == 'c') { + *(*cursorPtr)++ = (char)(value & 0xff); + } else if (cmd == 's') { + *(*cursorPtr)++ = (char)(value & 0xff); + *(*cursorPtr)++ = (char)((value >> 8) & 0xff); + } else if (cmd == 'S') { + *(*cursorPtr)++ = (char)((value >> 8) & 0xff); + *(*cursorPtr)++ = (char)(value & 0xff); + } else if (cmd == 'i') { + *(*cursorPtr)++ = (char)(value & 0xff); + *(*cursorPtr)++ = (char)((value >> 8) & 0xff); + *(*cursorPtr)++ = (char)((value >> 16) & 0xff); + *(*cursorPtr)++ = (char)((value >> 24) & 0xff); + } else if (cmd == 'I') { + *(*cursorPtr)++ = (char)((value >> 24) & 0xff); + *(*cursorPtr)++ = (char)((value >> 16) & 0xff); + *(*cursorPtr)++ = (char)((value >> 8) & 0xff); + *(*cursorPtr)++ = (char)(value & 0xff); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ScanNumber -- + * + * This routine is called by Tcl_BinaryObjCmd to scan a number + * out of a buffer. + * + * Results: + * Returns a newly created object containing the scanned number. + * This object has a ref count of zero. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +ScanNumber(buffer, type) + char *buffer; /* Buffer to scan number from. */ + int type; /* Format character from "binary scan" */ +{ + int value; + + /* + * We cannot rely on the compiler to properly sign extend integer values + * when we cast from smaller values to larger values because we don't know + * the exact size of the integer types. So, we have to handle sign + * extension explicitly by checking the high bit and padding with 1's as + * needed. + */ + + switch ((char) type) { + case 'c': + value = buffer[0]; + + if (value & 0x80) { + value |= -0x100; + } + return Tcl_NewLongObj((long)value); + case 's': + value = (((unsigned char)buffer[0]) + + ((unsigned char)buffer[1] << 8)); + goto shortValue; + case 'S': + value = (((unsigned char)buffer[1]) + + ((unsigned char)buffer[0] << 8)); + shortValue: + if (value & 0x8000) { + value |= -0x10000; + } + return Tcl_NewLongObj((long)value); + case 'i': + value = (((unsigned char)buffer[0]) + + ((unsigned char)buffer[1] << 8) + + ((unsigned char)buffer[2] << 16) + + ((unsigned char)buffer[3] << 24)); + goto intValue; + case 'I': + value = (((unsigned char)buffer[3]) + + ((unsigned char)buffer[2] << 8) + + ((unsigned char)buffer[1] << 16) + + ((unsigned char)buffer[0] << 24)); + intValue: + /* + * Check to see if the value was sign extended properly on + * systems where an int is more than 32-bits. + */ + + if ((value & (((unsigned int)1)<<31)) && (value > 0)) { + value -= (((unsigned int)1)<<31); + value -= (((unsigned int)1)<<31); + } + + return Tcl_NewLongObj((long)value); + case 'f': { + float fvalue; + memcpy(&fvalue, buffer, sizeof(float)); + return Tcl_NewDoubleObj(fvalue); + } + case 'd': { + double dvalue; + memcpy(&dvalue, buffer, sizeof(double)); + return Tcl_NewDoubleObj(dvalue); + } + } + return NULL; +} diff --git a/tcl/generic/tclCkalloc.c b/tcl/generic/tclCkalloc.c new file mode 100644 index 00000000000..fa089fccfea --- /dev/null +++ b/tcl/generic/tclCkalloc.c @@ -0,0 +1,817 @@ +/* + * tclCkalloc.c -- + * + * Interface to malloc and free that provides support for debugging problems + * involving overwritten, double freeing memory and loss of memory. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * This code contributed by Karl Lehenbauer and Mark Diekhans + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +#define FALSE 0 +#define TRUE 1 + +#ifdef TCL_MEM_DEBUG + +/* + * One of the following structures is allocated each time the + * "memory tag" command is invoked, to hold the current tag. + */ + +typedef struct MemTag { + int refCount; /* Number of mem_headers referencing + * this tag. */ + char string[4]; /* Actual size of string will be as + * large as needed for actual tag. This + * must be the last field in the structure. */ +} MemTag; + +#define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3) + +static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers + * (set by "memory tag" command). */ + +/* + * One of the following structures is allocated just before each + * dynamically allocated chunk of memory, both to record information + * about the chunk and to help detect chunk under-runs. + */ + +#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) +struct mem_header { + struct mem_header *flink; + struct mem_header *blink; + MemTag *tagPtr; /* Tag from "memory tag" command; may be + * NULL. */ + char *file; + long length; + int line; + unsigned char low_guard[LOW_GUARD_SIZE]; + /* Aligns body on 8-byte boundary, plus + * provides at least 8 additional guard bytes + * to detect underruns. */ + char body[1]; /* First byte of client's space. Actual + * size of this field will be larger than + * one. */ +}; + +static struct mem_header *allocHead = NULL; /* List of allocated structures */ + +#define GUARD_VALUE 0141 + +/* + * The following macro determines the amount of guard space *above* each + * chunk of memory. + */ + +#define HIGH_GUARD_SIZE 8 + +/* + * The following macro computes the offset of the "body" field within + * mem_header. It is used to get back to the header pointer from the + * body pointer that's used by clients. + */ + +#define BODY_OFFSET \ + ((unsigned long) (&((struct mem_header *) 0)->body)) + +static int total_mallocs = 0; +static int total_frees = 0; +static int current_bytes_malloced = 0; +static int maximum_bytes_malloced = 0; +static int current_malloc_packets = 0; +static int maximum_malloc_packets = 0; +static int break_on_malloc = 0; +static int trace_on_at_malloc = 0; +static int alloc_tracing = FALSE; +static int init_malloced_bodies = TRUE; +#ifdef MEM_VALIDATE + static int validate_memory = TRUE; +#else + static int validate_memory = FALSE; +#endif + +/* + * Prototypes for procedures defined in this file: + */ + +static int MemoryCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void ValidateMemory _ANSI_ARGS_(( + struct mem_header *memHeaderP, char *file, + int line, int nukeGuards)); + +/* + *---------------------------------------------------------------------- + * + * TclDumpMemoryInfo -- + * Display the global memory management statistics. + * + *---------------------------------------------------------------------- + */ +void +TclDumpMemoryInfo(outFile) + FILE *outFile; +{ + fprintf(outFile,"total mallocs %10d\n", + total_mallocs); + fprintf(outFile,"total frees %10d\n", + total_frees); + fprintf(outFile,"current packets allocated %10d\n", + current_malloc_packets); + fprintf(outFile,"current bytes allocated %10d\n", + current_bytes_malloced); + fprintf(outFile,"maximum packets allocated %10d\n", + maximum_malloc_packets); + fprintf(outFile,"maximum bytes allocated %10d\n", + maximum_bytes_malloced); +} + +/* + *---------------------------------------------------------------------- + * + * ValidateMemory -- + * Procedure to validate allocted memory guard zones. + * + *---------------------------------------------------------------------- + */ +static void +ValidateMemory(memHeaderP, file, line, nukeGuards) + struct mem_header *memHeaderP; + char *file; + int line; + int nukeGuards; +{ + unsigned char *hiPtr; + int idx; + int guard_failed = FALSE; + int byte; + + for (idx = 0; idx < LOW_GUARD_SIZE; idx++) { + byte = *(memHeaderP->low_guard + idx); + if (byte != GUARD_VALUE) { + guard_failed = TRUE; + fflush(stdout); + byte &= 0xff; + fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, + (isprint(UCHAR(byte)) ? byte : ' ')); + } + } + if (guard_failed) { + TclDumpMemoryInfo (stderr); + fprintf(stderr, "low guard failed at %lx, %s %d\n", + (long unsigned int) memHeaderP->body, file, line); + fflush(stderr); /* In case name pointer is bad. */ + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, + memHeaderP->file, memHeaderP->line); + panic ("Memory validation failure"); + } + + hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; + for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { + byte = *(hiPtr + idx); + if (byte != GUARD_VALUE) { + guard_failed = TRUE; + fflush (stdout); + byte &= 0xff; + fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, + (isprint(UCHAR(byte)) ? byte : ' ')); + } + } + + if (guard_failed) { + TclDumpMemoryInfo (stderr); + fprintf(stderr, "high guard failed at %lx, %s %d\n", + (long unsigned int) memHeaderP->body, file, line); + fflush(stderr); /* In case name pointer is bad. */ + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", + memHeaderP->length, memHeaderP->file, + memHeaderP->line); + panic("Memory validation failure"); + } + + if (nukeGuards) { + memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); + memset ((char *) hiPtr, 0, HIGH_GUARD_SIZE); + } + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ValidateAllMemory -- + * Validates guard regions for all allocated memory. + * + *---------------------------------------------------------------------- + */ +void +Tcl_ValidateAllMemory (file, line) + char *file; + int line; +{ + struct mem_header *memScanP; + + for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) + ValidateMemory(memScanP, file, line, FALSE); + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DumpActiveMemory -- + * Displays all allocated memory to stderr. + * + * Results: + * Return TCL_ERROR if an error accessing the file occures, `errno' + * will have the file error number left in it. + *---------------------------------------------------------------------- + */ +int +Tcl_DumpActiveMemory (fileName) + char *fileName; +{ + FILE *fileP; + struct mem_header *memScanP; + char *address; + + fileP = fopen(fileName, "w"); + if (fileP == NULL) + return TCL_ERROR; + + for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { + address = &memScanP->body [0]; + fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", + (long unsigned int) address, + (long unsigned int) address + memScanP->length - 1, + memScanP->length, memScanP->file, memScanP->line, + (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); + (void) fputc('\n', fileP); + } + fclose (fileP); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbCkalloc - debugging ckalloc + * + * Allocate the requested amount of space plus some extra for + * guard bands at both ends of the request, plus a size, panicing + * if there isn't enough space, then write in the guard bands + * and return the address of the space in the middle that the + * user asked for. + * + * The second and third arguments are file and line, these contain + * the filename and line number corresponding to the caller. + * These are sent by the ckalloc macro; it uses the preprocessor + * autodefines __FILE__ and __LINE__. + * + *---------------------------------------------------------------------- + */ +char * +Tcl_DbCkalloc(size, file, line) + unsigned int size; + char *file; + int line; +{ + struct mem_header *result; + + if (validate_memory) + Tcl_ValidateAllMemory (file, line); + + result = (struct mem_header *) TclpAlloc((unsigned)size + + sizeof(struct mem_header) + HIGH_GUARD_SIZE); + if (result == NULL) { + fflush(stdout); + TclDumpMemoryInfo(stderr); + panic("unable to alloc %d bytes, %s line %d", size, file, + line); + } + + /* + * Fill in guard zones and size. Also initialize the contents of + * the block with bogus bytes to detect uses of initialized data. + * Link into allocated list. + */ + if (init_malloced_bodies) { + memset ((VOID *) result, GUARD_VALUE, + size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); + } else { + memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); + memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); + } + result->length = size; + result->tagPtr = curTagPtr; + if (curTagPtr != NULL) { + curTagPtr->refCount++; + } + result->file = file; + result->line = line; + result->flink = allocHead; + result->blink = NULL; + if (allocHead != NULL) + allocHead->blink = result; + allocHead = result; + + total_mallocs++; + if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { + (void) fflush(stdout); + fprintf(stderr, "reached malloc trace enable point (%d)\n", + total_mallocs); + fflush(stderr); + alloc_tracing = TRUE; + trace_on_at_malloc = 0; + } + + if (alloc_tracing) + fprintf(stderr,"ckalloc %lx %d %s %d\n", + (long unsigned int) result->body, size, file, line); + + if (break_on_malloc && (total_mallocs >= break_on_malloc)) { + break_on_malloc = 0; + (void) fflush(stdout); + fprintf(stderr,"reached malloc break limit (%d)\n", + total_mallocs); + fprintf(stderr, "program will now enter C debugger\n"); + (void) fflush(stderr); + abort(); + } + + current_malloc_packets++; + if (current_malloc_packets > maximum_malloc_packets) + maximum_malloc_packets = current_malloc_packets; + current_bytes_malloced += size; + if (current_bytes_malloced > maximum_bytes_malloced) + maximum_bytes_malloced = current_bytes_malloced; + + return result->body; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbCkfree - debugging ckfree + * + * Verify that the low and high guards are intact, and if so + * then free the buffer else panic. + * + * The guards are erased after being checked to catch duplicate + * frees. + * + * The second and third arguments are file and line, these contain + * the filename and line number corresponding to the caller. + * These are sent by the ckfree macro; it uses the preprocessor + * autodefines __FILE__ and __LINE__. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DbCkfree(ptr, file, line) + char * ptr; + char *file; + int line; +{ + /* + * The following cast is *very* tricky. Must convert the pointer + * to an integer before doing arithmetic on it, because otherwise + * the arithmetic will be done differently (and incorrectly) on + * word-addressed machines such as Crays (will subtract only bytes, + * even though BODY_OFFSET is in words on these machines). + */ + + struct mem_header *memp = (struct mem_header *) + (((unsigned long) ptr) - BODY_OFFSET); + + if (alloc_tracing) + fprintf(stderr, "ckfree %lx %ld %s %d\n", + (long unsigned int) memp->body, memp->length, file, line); + + if (validate_memory) + Tcl_ValidateAllMemory(file, line); + + ValidateMemory(memp, file, line, TRUE); + if (init_malloced_bodies) { + memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length); + } + + total_frees++; + current_malloc_packets--; + current_bytes_malloced -= memp->length; + + if (memp->tagPtr != NULL) { + memp->tagPtr->refCount--; + if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { + TclpFree((char *) memp->tagPtr); + } + } + + /* + * Delink from allocated list + */ + if (memp->flink != NULL) + memp->flink->blink = memp->blink; + if (memp->blink != NULL) + memp->blink->flink = memp->flink; + if (allocHead == memp) + allocHead = memp->flink; + TclpFree((char *) memp); + return 0; +} + +/* + *-------------------------------------------------------------------- + * + * Tcl_DbCkrealloc - debugging ckrealloc + * + * Reallocate a chunk of memory by allocating a new one of the + * right size, copying the old data to the new location, and then + * freeing the old memory space, using all the memory checking + * features of this package. + * + *-------------------------------------------------------------------- + */ +char * +Tcl_DbCkrealloc(ptr, size, file, line) + char *ptr; + unsigned int size; + char *file; + int line; +{ + char *new; + unsigned int copySize; + + /* + * See comment from Tcl_DbCkfree before you change the following + * line. + */ + + struct mem_header *memp = (struct mem_header *) + (((unsigned long) ptr) - BODY_OFFSET); + + copySize = size; + if (copySize > (unsigned int) memp->length) { + copySize = memp->length; + } + new = Tcl_DbCkalloc(size, file, line); + memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize); + Tcl_DbCkfree(ptr, file, line); + return(new); +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_Alloc, et al. -- + * + * These functions are defined in terms of the debugging versions + * when TCL_MEM_DEBUG is set. + * + * Results: + * Same as the debug versions. + * + * Side effects: + * Same as the debug versions. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_Alloc +#undef Tcl_Free +#undef Tcl_Realloc + +char * +Tcl_Alloc(size) + unsigned int size; +{ + return Tcl_DbCkalloc(size, "unknown", 0); +} + +void +Tcl_Free(ptr) + char *ptr; +{ + Tcl_DbCkfree(ptr, "unknown", 0); +} + +char * +Tcl_Realloc(ptr, size) + char *ptr; + unsigned int size; +{ + return Tcl_DbCkrealloc(ptr, size, "unknown", 0); +} + +/* + *---------------------------------------------------------------------- + * + * MemoryCmd -- + * Implements the TCL memory command: + * memory info + * memory display + * break_on_malloc count + * trace_on_at_malloc count + * trace on|off + * validate on|off + * + * Results: + * Standard TCL results. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +static int +MemoryCmd (clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + char **argv; +{ + char *fileName; + Tcl_DString buffer; + int result; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option [args..]\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1],"active") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " active file\"", (char *) NULL); + return TCL_ERROR; + } + fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); + if (fileName == NULL) { + return TCL_ERROR; + } + result = Tcl_DumpActiveMemory (fileName); + Tcl_DStringFree(&buffer); + if (result != TCL_OK) { + Tcl_AppendResult(interp, "error accessing ", argv[2], + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + } + if (strcmp(argv[1],"break_on_malloc") == 0) { + if (argc != 3) { + goto argError; + } + if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; + } + if (strcmp(argv[1],"info") == 0) { + TclDumpMemoryInfo(stdout); + return TCL_OK; + } + if (strcmp(argv[1],"init") == 0) { + if (argc != 3) { + goto bad_suboption; + } + init_malloced_bodies = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + if (strcmp(argv[1],"tag") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " tag string\"", (char *) NULL); + return TCL_ERROR; + } + if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { + TclpFree((char *) curTagPtr); + } + curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2]))); + curTagPtr->refCount = 0; + strcpy(curTagPtr->string, argv[2]); + return TCL_OK; + } + if (strcmp(argv[1],"trace") == 0) { + if (argc != 3) { + goto bad_suboption; + } + alloc_tracing = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + + if (strcmp(argv[1],"trace_on_at_malloc") == 0) { + if (argc != 3) { + goto argError; + } + if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; + } + if (strcmp(argv[1],"validate") == 0) { + if (argc != 3) { + goto bad_suboption; + } + validate_memory = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be active, break_on_malloc, info, init, ", + "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); + return TCL_ERROR; + +argError: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " count\"", (char *) NULL); + return TCL_ERROR; + +bad_suboption: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " on|off\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitMemory -- + * Initialize the memory command. + * + *---------------------------------------------------------------------- + */ +void +Tcl_InitMemory(interp) + Tcl_Interp *interp; +{ + Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc *) NULL); +} + +#else + + +/* + *---------------------------------------------------------------------- + * + * Tcl_Alloc -- + * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check + * that memory was actually allocated. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Alloc (size) + unsigned int size; +{ + char *result; + + result = TclpAlloc(size); + /* CYGNUS LOCAL -- check that size is not zero */ + if (result == NULL && size ) + panic("unable to alloc %d bytes", size); + /* End CYGNUS LOCAL */ + return result; +} + +char * +Tcl_DbCkalloc(size, file, line) + unsigned int size; + char *file; + int line; +{ + char *result; + + result = (char *) TclpAlloc(size); + + if (result == NULL) { + fflush(stdout); + panic("unable to alloc %d bytes, %s line %d", size, file, + line); + } + return result; +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_Realloc -- + * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does + * check that memory was actually allocated. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Realloc(ptr, size) + char *ptr; + unsigned int size; +{ + char *result; + + result = TclpRealloc(ptr, size); + if (result == NULL) + panic("unable to realloc %d bytes", size); + return result; +} + +char * +Tcl_DbCkrealloc(ptr, size, file, line) + char *ptr; + unsigned int size; + char *file; + int line; +{ + char *result; + + result = (char *) TclpRealloc(ptr, size); + + if (result == NULL) { + fflush(stdout); + panic("unable to realloc %d bytes, %s line %d", size, file, + line); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Free -- + * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here + * rather in the macro to keep some modules from being compiled with + * TCL_MEM_DEBUG enabled and some with it disabled. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Free (ptr) + char *ptr; +{ + TclpFree(ptr); +} + +int +Tcl_DbCkfree(ptr, file, line) + char * ptr; + char *file; + int line; +{ + TclpFree(ptr); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitMemory -- + * Dummy initialization for memory command, which is only available + * if TCL_MEM_DEBUG is on. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +void +Tcl_InitMemory(interp) + Tcl_Interp *interp; +{ +} + +#undef Tcl_DumpActiveMemory +#undef Tcl_ValidateAllMemory + +extern int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); +extern void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, + int line)); + +int +Tcl_DumpActiveMemory(fileName) + char *fileName; +{ + return TCL_OK; +} + +void +Tcl_ValidateAllMemory(file, line) + char *file; + int line; +{ +} + +#endif diff --git a/tcl/generic/tclClock.c b/tcl/generic/tclClock.c new file mode 100644 index 00000000000..29ed3560539 --- /dev/null +++ b/tcl/generic/tclClock.c @@ -0,0 +1,307 @@ +/* + * tclClock.c -- + * + * Contains the time and date related commands. This code + * is derived from the time and date facilities of TclX, + * by Mark Diekhans and Karl Lehenbauer. + * + * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans. + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tcl.h" +#include "tclInt.h" +#include "tclPort.h" + +/* + * Function prototypes for local procedures in this file: + */ + +static int FormatClock _ANSI_ARGS_((Tcl_Interp *interp, + unsigned long clockVal, int useGMT, + char *format)); + +/* + *------------------------------------------------------------------------- + * + * Tcl_ClockObjCmd -- + * + * This procedure is invoked to process the "clock" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *------------------------------------------------------------------------- + */ + +int +Tcl_ClockObjCmd (client, interp, objc, objv) + ClientData client; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument values. */ +{ + Tcl_Obj *resultPtr; + int index; + Tcl_Obj *CONST *objPtr; + int useGMT = 0; + char *format = "%a %b %d %X %Z %Y"; + int dummy; + unsigned long baseClock, clockVal; + long zone; + Tcl_Obj *baseObjPtr = NULL; + char *scanStr; + + static char *switches[] = + {"clicks", "format", "scan", "seconds", (char *) NULL}; + static char *formatSwitches[] = {"-format", "-gmt", (char *) NULL}; + static char *scanSwitches[] = {"-base", "-gmt", (char *) NULL}; + + resultPtr = Tcl_GetObjResult(interp); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], switches, "option", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case 0: /* clicks */ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_SetLongObj(resultPtr, (long) TclpGetClicks()); + return TCL_OK; + case 1: /* format */ + if ((objc < 3) || (objc > 7)) { + wrongFmtArgs: + Tcl_WrongNumArgs(interp, 2, objv, + "clockval ?-format string? ?-gmt boolean?"); + return TCL_ERROR; + } + + if (Tcl_GetLongFromObj(interp, objv[2], (long*) &clockVal) + != TCL_OK) { + return TCL_ERROR; + } + + objPtr = objv+3; + objc -= 3; + while (objc > 1) { + if (Tcl_GetIndexFromObj(interp, objPtr[0], formatSwitches, + "switch", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case 0: /* -format */ + format = Tcl_GetStringFromObj(objPtr[1], &dummy); + break; + case 1: /* -gmt */ + if (Tcl_GetBooleanFromObj(interp, objPtr[1], + &useGMT) != TCL_OK) { + return TCL_ERROR; + } + break; + } + objPtr += 2; + objc -= 2; + } + if (objc != 0) { + goto wrongFmtArgs; + } + return FormatClock(interp, (unsigned long) clockVal, useGMT, + format); + case 2: /* scan */ + if ((objc < 3) || (objc > 7)) { + wrongScanArgs: + Tcl_WrongNumArgs(interp, 2, objv, + "dateString ?-base clockValue? ?-gmt boolean?"); + return TCL_ERROR; + } + + objPtr = objv+3; + objc -= 3; + while (objc > 1) { + if (Tcl_GetIndexFromObj(interp, objPtr[0], scanSwitches, + "switch", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case 0: /* -base */ + baseObjPtr = objPtr[1]; + break; + case 1: /* -gmt */ + if (Tcl_GetBooleanFromObj(interp, objPtr[1], + &useGMT) != TCL_OK) { + return TCL_ERROR; + } + break; + } + objPtr += 2; + objc -= 2; + } + if (objc != 0) { + goto wrongScanArgs; + } + + if (baseObjPtr != NULL) { + if (Tcl_GetLongFromObj(interp, baseObjPtr, + (long*) &baseClock) != TCL_OK) { + return TCL_ERROR; + } + } else { + baseClock = TclpGetSeconds(); + } + + if (useGMT) { + zone = -50000; /* Force GMT */ + } else { + zone = TclpGetTimeZone((unsigned long) baseClock); + } + + scanStr = Tcl_GetStringFromObj(objv[2], &dummy); + if (TclGetDate(scanStr, (unsigned long) baseClock, zone, + (unsigned long *) &clockVal) < 0) { + Tcl_AppendStringsToObj(resultPtr, + "unable to convert date-time string \"", + scanStr, "\"", (char *) NULL); + return TCL_ERROR; + } + + Tcl_SetLongObj(resultPtr, (long) clockVal); + return TCL_OK; + case 3: /* seconds */ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_SetLongObj(resultPtr, (long) TclpGetSeconds()); + return TCL_OK; + default: + return TCL_ERROR; /* Should never be reached. */ + } +} + +/* + *----------------------------------------------------------------------------- + * + * FormatClock -- + * + * Formats a time value based on seconds into a human readable + * string. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +static int +FormatClock(interp, clockVal, useGMT, format) + Tcl_Interp *interp; /* Current interpreter. */ + unsigned long clockVal; /* Time in seconds. */ + int useGMT; /* Boolean */ + char *format; /* Format string */ +{ + struct tm *timeDataPtr; + Tcl_DString buffer; + int bufSize; + char *p; +#ifdef TCL_USE_TIMEZONE_VAR + int savedTimeZone; + char *savedTZEnv; +#endif + Tcl_Obj *resultPtr; + + resultPtr = Tcl_GetObjResult(interp); +#ifdef HAVE_TZSET + /* + * Some systems forgot to call tzset in localtime, make sure its done. + */ + static int calledTzset = 0; + + if (!calledTzset) { + tzset(); + calledTzset = 1; + } +#endif + +#ifdef TCL_USE_TIMEZONE_VAR + /* + * This is a horrible kludge for systems not having the timezone in + * struct tm. No matter what was specified, they use the global time + * zone. (Thanks Solaris). + */ + if (useGMT) { + char *varValue; + + varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY); + if (varValue != NULL) { + savedTZEnv = strcpy(ckalloc(strlen(varValue) + 1), varValue); + } else { + savedTZEnv = NULL; + } + Tcl_SetVar2(interp, "env", "TZ", "GMT", TCL_GLOBAL_ONLY); + savedTimeZone = timezone; + timezone = 0; + tzset(); + } +#endif + + timeDataPtr = TclpGetDate((time_t *) &clockVal, useGMT); + + /* + * Make a guess at the upper limit on the substituted string size + * based on the number of percents in the string. + */ + + for (bufSize = 1, p = format; *p != '\0'; p++) { + if (*p == '%') { + bufSize += 40; + } else { + bufSize++; + } + } + Tcl_DStringInit(&buffer); + Tcl_DStringSetLength(&buffer, bufSize); + + if ((TclStrftime(buffer.string, (unsigned int) bufSize, format, + timeDataPtr) == 0) && (*format != '\0')) { + Tcl_AppendStringsToObj(resultPtr, "bad format string \"", + format, "\"", (char *) NULL); + return TCL_ERROR; + } + +#ifdef TCL_USE_TIMEZONE_VAR + if (useGMT) { + if (savedTZEnv != NULL) { + Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY); + ckfree(savedTZEnv); + } else { + Tcl_UnsetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY); + } + timezone = savedTimeZone; + tzset(); + } +#endif + + Tcl_SetStringObj(resultPtr, buffer.string, -1); + Tcl_DStringFree(&buffer); + return TCL_OK; +} + diff --git a/tcl/generic/tclCmdAH.c b/tcl/generic/tclCmdAH.c new file mode 100644 index 00000000000..4382b508220 --- /dev/null +++ b/tcl/generic/tclCmdAH.c @@ -0,0 +1,1977 @@ +/* + * tclCmdAH.c -- + * + * This file contains the top-level command routines for most of + * the Tcl built-in commands whose names begin with the letters + * A to H. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Prototypes for local procedures defined in this file: + */ + +static char * GetTypeFromMode _ANSI_ARGS_((int mode)); +static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, struct stat *statPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_BreakCmd -- + * + * This procedure is invoked to process the "break" Tcl command. + * See the user documentation for details on what it does. + * + * With the bytecode compiler, this procedure is only called when + * a command name is computed at runtime, and is "break" or the name + * to which "break" was renamed: e.g., "set z break; $z" + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_BreakCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_BREAK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CaseObjCmd -- + * + * This procedure is invoked to process the "case" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CaseObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register int i; + int body, result; + char *string, *arg; + int argLen, caseObjc; + Tcl_Obj *CONST *caseObjv; + Tcl_Obj *armPtr; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "string ?in? patList body ... ?default body?"); + return TCL_ERROR; + } + + /* + * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. + */ + + string = Tcl_GetStringFromObj(objv[1], &argLen); + body = -1; + + arg = Tcl_GetStringFromObj(objv[2], &argLen); + if (strcmp(arg, "in") == 0) { + i = 3; + } else { + i = 2; + } + caseObjc = objc - i; + caseObjv = objv + i; + + /* + * If all of the pattern/command pairs are lumped into a single + * argument, split them out again. + * THIS FAILS IF THE ARG'S STRING REP CONTAINS A NULL + */ + + if (caseObjc == 1) { + Tcl_Obj **newObjv; + + Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv); + caseObjv = newObjv; + } + + for (i = 0; i < caseObjc; i += 2) { + int patObjc, j; + char **patObjv; + char *pat; + register char *p; + + if (i == (caseObjc-1)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "extra case pattern with no body", -1); + return TCL_ERROR; + } + + /* + * Check for special case of single pattern (no list) with + * no backslash sequences. + */ + + pat = Tcl_GetStringFromObj(caseObjv[i], &argLen); + for (p = pat; *p != 0; p++) { /* FAILS IF NULL BYTE */ + if (isspace(UCHAR(*p)) || (*p == '\\')) { + break; + } + } + if (*p == 0) { + if ((*pat == 'd') && (strcmp(pat, "default") == 0)) { + body = i+1; + } + if (Tcl_StringMatch(string, pat)) { + body = i+1; + goto match; + } + continue; + } + + + /* + * Break up pattern lists, then check each of the patterns + * in the list. + */ + + result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); + if (result != TCL_OK) { + return result; + } + for (j = 0; j < patObjc; j++) { + if (Tcl_StringMatch(string, patObjv[j])) { + body = i+1; + break; + } + } + ckfree((char *) patObjv); + if (j < patObjc) { + break; + } + } + + match: + if (body != -1) { + armPtr = caseObjv[body-1]; + result = Tcl_EvalObj(interp, caseObjv[body]); + if (result == TCL_ERROR) { + char msg[100]; + + arg = Tcl_GetStringFromObj(armPtr, &argLen); + sprintf(msg, "\n (\"%.*s\" arm line %d)", argLen, arg, + interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + return result; + } + + /* + * Nothing matched: return nothing. + */ + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CatchObjCmd -- + * + * This object-based procedure is invoked to process the "catch" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CatchObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Obj *varNamePtr = NULL; + int result; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?"); + return TCL_ERROR; + } + + /* + * Save a pointer to the variable name object, if any, in case the + * Tcl_EvalObj reallocates the bytecode interpreter's evaluation + * stack rendering objv invalid. + */ + + if (objc == 3) { + varNamePtr = objv[2]; + } + + result = Tcl_EvalObj(interp, objv[1]); + + if (objc == 3) { + if (Tcl_ObjSetVar2(interp, varNamePtr, NULL, + Tcl_GetObjResult(interp), TCL_PARSE_PART1) == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "couldn't save command result in variable", -1); + return TCL_ERROR; + } + } + + /* + * Set the interpreter's object result to an integer object holding the + * integer Tcl_EvalObj result. Note that we don't bother generating a + * string representation. We reset the interpreter's object result + * to an unshared empty object and then set it to be an integer object. + */ + + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), result); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CdObjCmd -- + * + * This procedure is invoked to process the "cd" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CdObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *dirName; + int dirLength; + Tcl_DString buffer; + int result; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "dirName"); + return TCL_ERROR; + } + + if (objc == 2) { + dirName = Tcl_GetStringFromObj(objv[1], &dirLength); + } else { + dirName = "~"; + } + dirName = Tcl_TranslateFileName(interp, dirName, &buffer); + if (dirName == NULL) { + return TCL_ERROR; + } + result = TclChdir(interp, dirName); + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConcatObjCmd -- + * + * This object-based procedure is invoked to process the "concat" Tcl + * command. See the user documentation for details on what it does/ + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ConcatObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + if (objc >= 2) { + Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ContinueCmd - + * + * This procedure is invoked to process the "continue" Tcl command. + * See the user documentation for details on what it does. + * + * With the bytecode compiler, this procedure is only called when + * a command name is computed at runtime, and is "continue" or the name + * to which "continue" was renamed: e.g., "set z continue; $z" + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ContinueCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_CONTINUE; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrorObjCmd -- + * + * This procedure is invoked to process the "error" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ErrorObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + register Tcl_Obj *namePtr; + char *info; + int infoLen; + + if ((objc < 2) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?"); + return TCL_ERROR; + } + + if (objc >= 3) { /* process the optional info argument */ + info = Tcl_GetStringFromObj(objv[2], &infoLen); + if (*info != 0) { + Tcl_AddObjErrorInfo(interp, info, infoLen); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + } + + if (objc == 4) { + namePtr = Tcl_NewStringObj("errorCode", -1); + Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, objv[3], + TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; + Tcl_DecrRefCount(namePtr); /* we're done with name object */ + } + + Tcl_SetObjResult(interp, objv[1]); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObjCmd -- + * + * This object-based procedure is invoked to process the "eval" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_EvalObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int result; + register Tcl_Obj *objPtr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); + return TCL_ERROR; + } + + if (objc == 2) { + result = Tcl_EvalObj(interp, objv[1]); + } else { + /* + * More than one argument: concatenate them together with spaces + * between, then evaluate the result. + */ + + objPtr = Tcl_ConcatObj(objc-1, objv+1); + result = Tcl_EvalObj(interp, objPtr); + Tcl_DecrRefCount(objPtr); /* we're done with the object */ + } + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExitObjCmd -- + * + * This procedure is invoked to process the "exit" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ExitObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int value; + + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); + return TCL_ERROR; + } + + if (objc == 1) { + value = 0; + } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { + return TCL_ERROR; + } + Tcl_Exit(value); + /*NOTREACHED*/ + return TCL_OK; /* Better not ever reach this! */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExprObjCmd -- + * + * This object-based procedure is invoked to process the "expr" Tcl + * command. See the user documentation for details on what it does. + * + * With the bytecode compiler, this procedure is called in two + * circumstances: 1) to execute expr commands that are too complicated + * or too unsafe to try compiling directly into an inline sequence of + * instructions, and 2) to execute commands where the command name is + * computed at runtime and is "expr" or the name to which "expr" was + * renamed (e.g., "set z expr; $z 2+3") + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ExprObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Tcl_Obj *objPtr; + Tcl_Obj *resultPtr; + register char *bytes; + int length, i, result; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); + return TCL_ERROR; + } + + if (objc == 2) { + result = Tcl_ExprObj(interp, objv[1], &resultPtr); + if (result == TCL_OK) { + Tcl_SetObjResult(interp, resultPtr); + Tcl_DecrRefCount(resultPtr); /* done with the result object */ + } + return result; + } + + /* + * Create a new object holding the concatenated argument strings. + * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. + */ + + bytes = Tcl_GetStringFromObj(objv[1], &length); + objPtr = Tcl_NewStringObj(bytes, length); + Tcl_IncrRefCount(objPtr); + for (i = 2; i < objc; i++) { + Tcl_AppendToObj(objPtr, " ", 1); + bytes = Tcl_GetStringFromObj(objv[i], &length); + Tcl_AppendToObj(objPtr, bytes, length); + } + + /* + * Evaluate the concatenated string object. + */ + + result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result == TCL_OK) { + Tcl_SetObjResult(interp, resultPtr); + Tcl_DecrRefCount(resultPtr); /* done with the result object */ + } + + /* + * Free allocated resources. + */ + + Tcl_DecrRefCount(objPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FileObjCmd -- + * + * This procedure is invoked to process the "file" Tcl command. + * See the user documentation for details on what it does. + * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH + * EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FileObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *fileName, *extension, *errorString; + int statOp = 0; /* Init. to avoid compiler warning. */ + int length; + int mode = 0; /* Initialized only to prevent + * compiler warning message. */ + struct stat statBuf; + Tcl_DString buffer; + Tcl_Obj *resultPtr; + int index, result; + +/* + * This list of constants should match the fileOption string array below. + */ + +enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, + FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY, + FILE_ISFILE, FILE_JOIN, FILE_LSTAT, FILE_MTIME, FILE_MKDIR, + FILE_NATIVENAME, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE, + FILE_READLINK, FILE_RENAME, FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, + FILE_STAT, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE}; + + + static char *fileOptions[] = {"atime", "attributes", "copy", "delete", + "dirname", "executable", "exists", "extension", "isdirectory", + "isfile", "join", "lstat", "mtime", "mkdir", "nativename", + "owned", "pathtype", "readable", "readlink", "rename", + "rootname", "size", "split", "stat", "tail", "type", "volumes", + "writable", (char *) NULL}; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + + result = TCL_OK; + /* + * First, do the volumes command, since it is the only one that + * has objc == 2. + */ + + if ( index == FILE_VOLUMES) { + if ( objc != 2 ) { + Tcl_WrongNumArgs(interp, 1, objv, "volumes"); + return TCL_ERROR; + } + result = TclpListVolumes(interp); + return result; + } + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?arg ...?"); + return TCL_ERROR; + } + + Tcl_DStringInit(&buffer); + resultPtr = Tcl_GetObjResult(interp); + + + /* + * Handle operations on the file name. + */ + + switch (index) { + case FILE_ATTRIBUTES: + result = TclFileAttrsCmd(interp, objc - 2, objv + 2); + goto done; + case FILE_DIRNAME: { + int pargc; + char **pargv; + + if (objc != 3) { + errorString = "dirname name"; + goto not3Args; + } + + fileName = Tcl_GetStringFromObj(objv[2], &length); + + /* + * If there is only one element, and it starts with a tilde, + * perform tilde substitution and resplit the path. + */ + + Tcl_SplitPath(fileName, &pargc, &pargv); + if ((pargc == 1) && (*fileName == '~')) { + ckfree((char*) pargv); + fileName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (fileName == NULL) { + result = TCL_ERROR; + goto done; + } + Tcl_SplitPath(fileName, &pargc, &pargv); + Tcl_DStringSetLength(&buffer, 0); + } + + /* + * Return all but the last component. If there is only one + * component, return it if the path was non-relative, otherwise + * return the current directory. + */ + + if (pargc > 1) { + Tcl_JoinPath(pargc-1, pargv, &buffer); + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), + buffer.length); + } else if ((pargc == 0) + || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetStringObj(resultPtr, (tclPlatform == TCL_PLATFORM_MAC) + ? ":" : ".", 1); + } else { + Tcl_SetStringObj(resultPtr, pargv[0], -1); } + ckfree((char *)pargv); + goto done; + } + case FILE_TAIL: { + int pargc; + char **pargv; + + if (objc != 3) { + errorString = "tail name"; + goto not3Args; + } + + fileName = Tcl_GetStringFromObj(objv[2], &length); + + /* + * If there is only one element, and it starts with a tilde, + * perform tilde substitution and resplit the path. + */ + + Tcl_SplitPath(fileName, &pargc, &pargv); + if ((pargc == 1) && (*fileName == '~')) { + ckfree((char*) pargv); + fileName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (fileName == NULL) { + result = TCL_ERROR; + goto done; + } + Tcl_SplitPath(fileName, &pargc, &pargv); + Tcl_DStringSetLength(&buffer, 0); + } + + /* + * Return the last component, unless it is the only component, + * and it is the root of an absolute path. + */ + + if (pargc > 0) { + if ((pargc > 1) + || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetStringObj(resultPtr, pargv[pargc - 1], -1); + } + } + ckfree((char *)pargv); + goto done; + } + case FILE_ROOTNAME: { + char *fileName; + + if (objc != 3) { + errorString = "rootname name"; + goto not3Args; + } + + fileName = Tcl_GetStringFromObj(objv[2], &length); + extension = TclGetExtension(fileName); + if (extension == NULL) { + Tcl_SetObjResult(interp, objv[2]); + } else { + Tcl_SetStringObj(resultPtr, fileName, + (int) (length - strlen(extension))); + } + goto done; + } + case FILE_EXTENSION: + if (objc != 3) { + errorString = "extension name"; + goto not3Args; + } + extension = TclGetExtension(Tcl_GetStringFromObj(objv[2],&length)); + + if (extension != NULL) { + Tcl_SetStringObj(resultPtr, extension, (int)strlen(extension)); + } + goto done; + case FILE_PATHTYPE: + if (objc != 3) { + errorString = "pathtype name"; + goto not3Args; + } + switch (Tcl_GetPathType(Tcl_GetStringFromObj(objv[2], &length))) { + case TCL_PATH_ABSOLUTE: + Tcl_SetStringObj(resultPtr, "absolute", -1); + break; + case TCL_PATH_RELATIVE: + Tcl_SetStringObj(resultPtr, "relative", -1); + break; + case TCL_PATH_VOLUME_RELATIVE: + Tcl_SetStringObj(resultPtr, "volumerelative", -1); + break; + } + goto done; + case FILE_SPLIT: { + int pargc, i; + char **pargvList; + Tcl_Obj *listObjPtr; + + if (objc != 3) { + errorString = "split name"; + goto not3Args; + } + + Tcl_SplitPath(Tcl_GetStringFromObj(objv[2], &length), &pargc, + &pargvList); + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + for (i = 0; i < pargc; i++) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(pargvList[i], -1)); + } + ckfree((char *) pargvList); + Tcl_SetObjResult(interp, listObjPtr); + goto done; + } + case FILE_JOIN: { + char **pargv = (char **) ckalloc((objc - 2) * sizeof(char *)); + int i; + + for (i = 2; i < objc; i++) { + pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length); + } + Tcl_JoinPath(objc - 2, pargv, &buffer); + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), + buffer.length); + ckfree((char *) pargv); + Tcl_DStringFree(&buffer); + goto done; + } + case FILE_RENAME: { + char **pargv = (char **) ckalloc(objc * sizeof(char *)); + int i; + + for (i = 0; i < objc; i++) { + pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + } + result = TclFileRenameCmd(interp, objc, pargv); + ckfree((char *) pargv); + goto done; + } + case FILE_MKDIR: { + char **pargv = (char **) ckalloc(objc * sizeof(char *)); + int i; + + for (i = 0; i < objc; i++) { + pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + } + result = TclFileMakeDirsCmd(interp, objc, pargv); + ckfree((char *) pargv); + goto done; + } + case FILE_DELETE: { + char **pargv = (char **) ckalloc(objc * sizeof(char *)); + int i; + + for (i = 0; i < objc; i++) { + pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + } + result = TclFileDeleteCmd(interp, objc, pargv); + ckfree((char *) pargv); + goto done; + } + case FILE_COPY: { + char **pargv = (char **) ckalloc(objc * sizeof(char *)); + int i; + + for (i = 0; i < objc; i++) { + pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + } + result = TclFileCopyCmd(interp, objc, pargv); + ckfree((char *) pargv); + goto done; + } + case FILE_NATIVENAME: + fileName = Tcl_TranslateFileName(interp, + Tcl_GetStringFromObj(objv[2], &length), &buffer); + if (fileName == NULL) { + result = TCL_ERROR ; + } else { + Tcl_SetStringObj(resultPtr, fileName, -1); + } + goto done; + } + + /* + * Next, handle operations that can be satisfied with the "access" + * kernel call. + */ + + fileName = Tcl_TranslateFileName(interp, + Tcl_GetStringFromObj(objv[2], &length), &buffer); + + switch (index) { + case FILE_READABLE: + if (objc != 3) { + errorString = "readable name"; + goto not3Args; + } + mode = R_OK; +checkAccess: + /* + * The result might have been set within Tcl_TranslateFileName + * (like no such user "blah" for file exists ~blah) + * but we don't want to flag an error in that case. + */ + if (fileName == NULL) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + } else { + Tcl_SetBooleanObj(resultPtr, (TclAccess(fileName, mode) != -1)); + } + goto done; + case FILE_WRITABLE: + if (objc != 3) { + errorString = "writable name"; + goto not3Args; + } + mode = W_OK; + goto checkAccess; + case FILE_EXECUTABLE: + if (objc != 3) { + errorString = "executable name"; + goto not3Args; + } + mode = X_OK; + goto checkAccess; + case FILE_EXISTS: + if (objc != 3) { + errorString = "exists name"; + goto not3Args; + } + mode = F_OK; + goto checkAccess; + } + + + /* + * Lastly, check stuff that requires the file to be stat-ed. + */ + + if (fileName == NULL) { + result = TCL_ERROR; + goto done; + } + + switch (index) { + case FILE_ATIME: + if (objc != 3) { + errorString = "atime name"; + goto not3Args; + } + + if (TclStat(fileName, &statBuf) == -1) { + goto badStat; + } + Tcl_SetLongObj(resultPtr, (long) statBuf.st_atime); + goto done; + case FILE_ISDIRECTORY: + if (objc != 3) { + errorString = "isdirectory name"; + goto not3Args; + } + statOp = 2; + break; + case FILE_ISFILE: + if (objc != 3) { + errorString = "isfile name"; + goto not3Args; + } + statOp = 1; + break; + case FILE_LSTAT: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "lstat name varName"); + result = TCL_ERROR; + goto done; + } + + if (lstat(fileName, &statBuf) == -1) { + Tcl_AppendStringsToObj(resultPtr, "couldn't lstat \"", + Tcl_GetStringFromObj(objv[2], &length), "\": ", + Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3], + &length), &statBuf); + goto done; + case FILE_MTIME: + if (objc != 3) { + errorString = "mtime name"; + goto not3Args; + } + if (TclStat(fileName, &statBuf) == -1) { + goto badStat; + } + Tcl_SetLongObj(resultPtr, (long) statBuf.st_mtime); + goto done; + case FILE_OWNED: + if (objc != 3) { + errorString = "owned name"; + goto not3Args; + } + statOp = 0; + break; + case FILE_READLINK: { + char linkValue[MAXPATHLEN + 1]; + int linkLength; + + if (objc != 3) { + errorString = "readlink name"; + goto not3Args; + } + + /* + * If S_IFLNK isn't defined it means that the machine doesn't + * support symbolic links, so the file can't possibly be a + * symbolic link. Generate an EINVAL error, which is what + * happens on machines that do support symbolic links when + * you invoke readlink on a file that isn't a symbolic link. + */ + +#ifndef S_IFLNK + linkLength = -1; + errno = EINVAL; +#else + linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1); +#endif /* S_IFLNK */ + if (linkLength == -1) { + Tcl_AppendStringsToObj(resultPtr, "couldn't readlink \"", + Tcl_GetStringFromObj(objv[2], &length), "\": ", + Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + linkValue[linkLength] = 0; + Tcl_SetStringObj(resultPtr, linkValue, linkLength); + goto done; + } + case FILE_SIZE: + if (objc != 3) { + errorString = "size name"; + goto not3Args; + } + if (TclStat(fileName, &statBuf) == -1) { + goto badStat; + } + Tcl_SetLongObj(resultPtr, (long) statBuf.st_size); + goto done; + case FILE_STAT: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); + result = TCL_ERROR; + goto done; + } + + if (TclStat(fileName, &statBuf) == -1) { +badStat: + Tcl_AppendStringsToObj(resultPtr, "couldn't stat \"", + Tcl_GetStringFromObj(objv[2], &length), + "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3], + &length), &statBuf); + goto done; + case FILE_TYPE: + if (objc != 3) { + errorString = "type name"; + goto not3Args; + } + if (lstat(fileName, &statBuf) == -1) { + goto badStat; + } + errorString = GetTypeFromMode((int) statBuf.st_mode); + Tcl_SetStringObj(resultPtr, errorString, -1); + goto done; + } + + if (TclStat(fileName, &statBuf) == -1) { + Tcl_SetBooleanObj(resultPtr, 0); + goto done; + } + switch (statOp) { + case 0: + /* + * For Windows and Macintosh, there are no user ids + * associated with a file, so we always return 1. + */ + +#if (defined(__WIN32__) || defined(MAC_TCL)) + mode = 1; +#else + mode = (geteuid() == statBuf.st_uid); +#endif + break; + case 1: + mode = S_ISREG(statBuf.st_mode); + break; + case 2: + mode = S_ISDIR(statBuf.st_mode); + break; + } + Tcl_SetBooleanObj(resultPtr, mode); + +done: + Tcl_DStringFree(&buffer); + return result; + +not3Args: + Tcl_WrongNumArgs(interp, 1, objv, errorString); + result = TCL_ERROR; + goto done; +} + +/* + *---------------------------------------------------------------------- + * + * StoreStatData -- + * + * This is a utility procedure that breaks out the fields of a + * "stat" structure and stores them in textual form into the + * elements of an associative array. + * + * Results: + * Returns a standard Tcl return value. If an error occurs then + * a message is left in interp->result. + * + * Side effects: + * Elements of the associative array given by "varName" are modified. + * + *---------------------------------------------------------------------- + */ + +static int +StoreStatData(interp, varName, statPtr) + Tcl_Interp *interp; /* Interpreter for error reports. */ + char *varName; /* Name of associative array variable + * in which to store stat results. */ + struct stat *statPtr; /* Pointer to buffer containing + * stat data to store in varName. */ +{ + char string[30]; + + sprintf(string, "%ld", (long) statPtr->st_dev); + if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_ino); + if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_mode); + if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_nlink); + if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_uid); + if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_gid); + if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%lu", (unsigned long) statPtr->st_size); + if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_atime); + if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_mtime); + if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_ctime); + if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + if (Tcl_SetVar2(interp, varName, "type", + GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetTypeFromMode -- + * + * Given a mode word, returns a string identifying the type of a + * file. + * + * Results: + * A static text string giving the file type from mode. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +GetTypeFromMode(mode) + int mode; +{ + if (S_ISREG(mode)) { + return "file"; + } else if (S_ISDIR(mode)) { + return "directory"; + } else if (S_ISCHR(mode)) { + return "characterSpecial"; + } else if (S_ISBLK(mode)) { + return "blockSpecial"; + } else if (S_ISFIFO(mode)) { + return "fifo"; +#ifdef S_ISLNK + } else if (S_ISLNK(mode)) { + return "link"; +#endif +#ifdef S_ISSOCK + } else if (S_ISSOCK(mode)) { + return "socket"; +#endif + } + return "unknown"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ForCmd -- + * + * This procedure is invoked to process the "for" Tcl command. + * See the user documentation for details on what it does. + * + * With the bytecode compiler, this procedure is only called when + * a command name is computed at runtime, and is "for" or the name + * to which "for" was renamed: e.g., + * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}" + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ForCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int result, value; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " start test next command\"", (char *) NULL); + return TCL_ERROR; + } + + result = Tcl_Eval(interp, argv[1]); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); + } + return result; + } + while (1) { + result = Tcl_ExprBoolean(interp, argv[2], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } + result = Tcl_Eval(interp, argv[4]); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + break; + } + result = Tcl_Eval(interp, argv[3]); + if (result == TCL_BREAK) { + break; + } else if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); + } + return result; + } + } + if (result == TCL_BREAK) { + result = TCL_OK; + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ForeachObjCmd -- + * + * This object-based procedure is invoked to process the "foreach" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ForeachObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int result = TCL_OK; + int i; /* i selects a value list */ + int j, maxj; /* Number of loop iterations */ + int v; /* v selects a loop variable */ + int numLists; /* Count of value lists */ + Tcl_Obj *bodyPtr; + + /* + * We copy the argument object pointers into a local array to avoid + * the problem that "objv" might become invalid. It is a pointer into + * the evaluation stack and that stack might be grown and reallocated + * if the loop body requires a large amount of stack space. + */ + +#define NUM_ARGS 9 + Tcl_Obj *(argObjStorage[NUM_ARGS]); + Tcl_Obj **argObjv = argObjStorage; + +#define STATIC_LIST_SIZE 4 + int indexArray[STATIC_LIST_SIZE]; /* Array of value list indices */ + int varcListArray[STATIC_LIST_SIZE]; /* # loop variables per list */ + Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */ + int argcListArray[STATIC_LIST_SIZE]; /* Array of value list sizes */ + Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */ + + int *index = indexArray; + int *varcList = varcListArray; + Tcl_Obj ***varvList = varvListArray; + int *argcList = argcListArray; + Tcl_Obj ***argvList = argvListArray; + + if (objc < 4 || (objc%2 != 0)) { + Tcl_WrongNumArgs(interp, 1, objv, + "varList list ?varList list ...? command"); + return TCL_ERROR; + } + + /* + * Create the object argument array "argObjv". Make sure argObjv is + * large enough to hold the objc arguments. + */ + + if (objc > NUM_ARGS) { + argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *)); + } + for (i = 0; i < objc; i++) { + argObjv[i] = objv[i]; + } + + /* + * Manage numList parallel value lists. + * argvList[i] is a value list counted by argcList[i] + * varvList[i] is the list of variables associated with the value list + * varcList[i] is the number of variables associated with the value list + * index[i] is the current pointer into the value list argvList[i] + */ + + numLists = (objc-2)/2; + if (numLists > STATIC_LIST_SIZE) { + index = (int *) ckalloc(numLists * sizeof(int)); + varcList = (int *) ckalloc(numLists * sizeof(int)); + varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **)); + argcList = (int *) ckalloc(numLists * sizeof(int)); + argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **)); + } + for (i = 0; i < numLists; i++) { + index[i] = 0; + varcList[i] = 0; + varvList[i] = (Tcl_Obj **) NULL; + argcList[i] = 0; + argvList[i] = (Tcl_Obj **) NULL; + } + + /* + * Break up the value lists and variable lists into elements + * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE. + */ + + maxj = 0; + for (i = 0; i < numLists; i++) { + result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], + &varcList[i], &varvList[i]); + if (result != TCL_OK) { + goto done; + } + if (varcList[i] < 1) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "foreach varlist is empty", -1); + result = TCL_ERROR; + goto done; + } + + result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], + &argcList[i], &argvList[i]); + if (result != TCL_OK) { + goto done; + } + + j = argcList[i] / varcList[i]; + if ((argcList[i] % varcList[i]) != 0) { + j++; + } + if (j > maxj) { + maxj = j; + } + } + + /* + * Iterate maxj times through the lists in parallel + * If some value lists run out of values, set loop vars to "" + */ + + bodyPtr = argObjv[objc-1]; + for (j = 0; j < maxj; j++) { + for (i = 0; i < numLists; i++) { + /* + * If a variable or value list object has been converted to + * another kind of Tcl object, convert it back to a list object + * and refetch the pointer to its element array. + */ + + if (argObjv[1+i*2]->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], + &varcList[i], &varvList[i]); + if (result != TCL_OK) { + panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i); + } + } + if (argObjv[2+i*2]->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], + &argcList[i], &argvList[i]); + if (result != TCL_OK) { + panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i); + } + } + + for (v = 0; v < varcList[i]; v++) { + int k = index[i]++; + Tcl_Obj *valuePtr, *varValuePtr; + int isEmptyObj = 0; + + if (k < argcList[i]) { + valuePtr = argvList[i][k]; + } else { + valuePtr = Tcl_NewObj(); /* empty string */ + isEmptyObj = 1; + } + varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL, + valuePtr, TCL_PARSE_PART1); + if (varValuePtr == NULL) { + if (isEmptyObj) { + Tcl_DecrRefCount(valuePtr); + } + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "couldn't set loop variable: \"", + Tcl_GetStringFromObj(varvList[i][v], (int *) NULL), + "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + + } + } + + result = Tcl_EvalObj(interp, bodyPtr); + if (result != TCL_OK) { + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result == TCL_BREAK) { + result = TCL_OK; + break; + } else if (result == TCL_ERROR) { + char msg[100]; + sprintf(msg, "\n (\"foreach\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + break; + } else { + break; + } + } + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + + done: + if (numLists > STATIC_LIST_SIZE) { + ckfree((char *) index); + ckfree((char *) varcList); + ckfree((char *) argcList); + ckfree((char *) varvList); + ckfree((char *) argvList); + } + if (argObjv != argObjStorage) { + ckfree((char *) argObjv); + } + return result; +#undef STATIC_LIST_SIZE +#undef NUM_ARGS +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FormatObjCmd -- + * + * This procedure is invoked to process the "format" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FormatObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register char *format; /* Used to read characters from the format + * string. */ + int formatLen; /* The length of the format string */ + char *endPtr; /* Points to the last char in format array */ + char newFormat[40]; /* A new format specifier is generated here. */ + int width; /* Field width from field specifier, or 0 if + * no width given. */ + int precision; /* Field precision from field specifier, or 0 + * if no precision given. */ + int size; /* Number of bytes needed for result of + * conversion, based on type of conversion + * ("e", "s", etc.), width, and precision. */ + int intValue; /* Used to hold value to pass to sprintf, if + * it's a one-word integer or char value */ + char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if + * it's a one-word value. */ + double doubleValue; /* Used to hold value to pass to sprintf if + * it's a double value. */ + int whichValue; /* Indicates which of intValue, ptrValue, + * or doubleValue has the value to pass to + * sprintf, according to the following + * definitions: */ +# define INT_VALUE 0 +# define PTR_VALUE 1 +# define DOUBLE_VALUE 2 +# define MAX_FLOAT_SIZE 320 + + Tcl_Obj *resultPtr; /* Where result is stored finally. */ + char staticBuf[MAX_FLOAT_SIZE + 1]; + /* A static buffer to copy the format results + * into */ + char *dst = staticBuf; /* The buffer that sprintf writes into each + * time the format processes a specifier */ + int dstSize = MAX_FLOAT_SIZE; + /* The size of the dst buffer */ + int noPercent; /* Special case for speed: indicates there's + * no field specifier, just a string to copy.*/ + int objIndex; /* Index of argument to substitute next. */ + int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style + * specifier has been seen. */ + int gotSequential = 0; /* Non-zero means that a regular sequential + * (non-XPG3) conversion specifier has been + * seen. */ + int useShort; /* Value to be printed is short (half word). */ + char *end; /* Used to locate end of numerical fields. */ + + /* + * This procedure is a bit nasty. The goal is to use sprintf to + * do most of the dirty work. There are several problems: + * 1. this procedure can't trust its arguments. + * 2. we must be able to provide a large enough result area to hold + * whatever's generated. This is hard to estimate. + * 2. there's no way to move the arguments from objv to the call + * to sprintf in a reasonable way. This is particularly nasty + * because some of the arguments may be two-word values (doubles). + * So, what happens here is to scan the format string one % group + * at a time, making many individual calls to sprintf. + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "formatString ?arg arg ...?"); + return TCL_ERROR; + } + + format = Tcl_GetStringFromObj(objv[1], &formatLen); + endPtr = format + formatLen; + resultPtr = Tcl_NewObj(); + objIndex = 2; + + while (format < endPtr) { + register char *newPtr = newFormat; + + width = precision = noPercent = useShort = 0; + whichValue = PTR_VALUE; + + /* + * Get rid of any characters before the next field specifier. + */ + if (*format != '%') { + ptrValue = format; + while ((*format != '%') && (format < endPtr)) { + format++; + } + size = format - ptrValue; + noPercent = 1; + goto doField; + } + + if (format[1] == '%') { + ptrValue = format; + size = 1; + noPercent = 1; + format += 2; + goto doField; + } + + /* + * Parse off a field specifier, compute how many characters + * will be needed to store the result, and substitute for + * "*" size specifiers. + */ + *newPtr = '%'; + newPtr++; + format++; + if (isdigit(UCHAR(*format))) { + int tmp; + + /* + * Check for an XPG3-style %n$ specification. Note: there + * must not be a mixture of XPG3 specs and non-XPG3 specs + * in the same format string. + */ + + tmp = strtoul(format, &end, 10); + if (*end != '$') { + goto notXpg; + } + format = end+1; + gotXpg = 1; + if (gotSequential) { + goto mixedXPG; + } + objIndex = tmp+1; + if ((objIndex < 2) || (objIndex >= objc)) { + goto badIndex; + } + goto xpgCheckDone; + } + + notXpg: + gotSequential = 1; + if (gotXpg) { + goto mixedXPG; + } + + xpgCheckDone: + while ((*format == '-') || (*format == '#') || (*format == '0') + || (*format == ' ') || (*format == '+')) { + *newPtr = *format; + newPtr++; + format++; + } + if (isdigit(UCHAR(*format))) { + width = strtoul(format, &end, 10); + format = end; + } else if (*format == '*') { + if (objIndex >= objc) { + goto badIndex; + } + if (Tcl_GetIntFromObj(interp, objv[objIndex], + &width) != TCL_OK) { + goto fmtError; + } + objIndex++; + format++; + } + if (width > 100000) { + /* + * Don't allow arbitrarily large widths: could cause core + * dump when we try to allocate a zillion bytes of memory + * below. + */ + + width = 100000; + } else if (width < 0) { + width = 0; + } + if (width != 0) { + TclFormatInt(newPtr, width); + while (*newPtr != 0) { + newPtr++; + } + } + if (*format == '.') { + *newPtr = '.'; + newPtr++; + format++; + } + if (isdigit(UCHAR(*format))) { + precision = strtoul(format, &end, 10); + format = end; + } else if (*format == '*') { + if (objIndex >= objc) { + goto badIndex; + } + if (Tcl_GetIntFromObj(interp, objv[objIndex], + &precision) != TCL_OK) { + goto fmtError; + } + objIndex++; + format++; + } + if (precision != 0) { + TclFormatInt(newPtr, precision); + while (*newPtr != 0) { + newPtr++; + } + } + if (*format == 'l') { + format++; + } else if (*format == 'h') { + useShort = 1; + *newPtr = 'h'; + newPtr++; + format++; + } + *newPtr = *format; + newPtr++; + *newPtr = 0; + if (objIndex >= objc) { + goto badIndex; + } + switch (*format) { + case 'i': + newPtr[-1] = 'd'; + case 'd': + case 'o': + case 'u': + case 'x': + case 'X': + if (Tcl_GetIntFromObj(interp, objv[objIndex], + (int *) &intValue) != TCL_OK) { + goto fmtError; + } + whichValue = INT_VALUE; + size = 40 + precision; + break; + case 's': + ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size); + break; + case 'c': + if (Tcl_GetIntFromObj(interp, objv[objIndex], + (int *) &intValue) != TCL_OK) { + goto fmtError; + } + whichValue = INT_VALUE; + size = 1; + break; + case 'e': + case 'E': + case 'f': + case 'g': + case 'G': + if (Tcl_GetDoubleFromObj(interp, objv[objIndex], + &doubleValue) != TCL_OK) { + goto fmtError; + } + whichValue = DOUBLE_VALUE; + size = MAX_FLOAT_SIZE; + if (precision > 10) { + size += precision; + } + break; + case 0: + Tcl_SetResult(interp, + "format string ended in middle of field specifier", + TCL_STATIC); + goto fmtError; + default: + { + char buf[40]; + sprintf(buf, "bad field specifier \"%c\"", *format); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + goto fmtError; + } + } + objIndex++; + format++; + + /* + * Make sure that there's enough space to hold the formatted + * result, then format it. + */ + + doField: + if (width > size) { + size = width; + } + if (noPercent) { + Tcl_AppendToObj(resultPtr, ptrValue, size); + } else { + if (size > dstSize) { + if (dst != staticBuf) { + ckfree(dst); + } + dst = (char *) ckalloc((unsigned) (size + 1)); + dstSize = size; + } + + if (whichValue == DOUBLE_VALUE) { + sprintf(dst, newFormat, doubleValue); + } else if (whichValue == INT_VALUE) { + if (useShort) { + sprintf(dst, newFormat, (short) intValue); + } else { + sprintf(dst, newFormat, intValue); + } + } else { + sprintf(dst, newFormat, ptrValue); + } + Tcl_AppendToObj(resultPtr, dst, -1); + } + } + + Tcl_SetObjResult(interp, resultPtr); + if(dst != staticBuf) { + ckfree(dst); + } + return TCL_OK; + + mixedXPG: + Tcl_SetResult(interp, + "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); + goto fmtError; + + badIndex: + if (gotXpg) { + Tcl_SetResult(interp, + "\"%n$\" argument index out of range", TCL_STATIC); + } else { + Tcl_SetResult(interp, + "not enough arguments for all format specifiers", TCL_STATIC); + } + + fmtError: + if(dst != staticBuf) { + ckfree(dst); + } + Tcl_DecrRefCount(resultPtr); + return TCL_ERROR; +} diff --git a/tcl/generic/tclCmdIL.c b/tcl/generic/tclCmdIL.c new file mode 100644 index 00000000000..94b8fc2dfc7 --- /dev/null +++ b/tcl/generic/tclCmdIL.c @@ -0,0 +1,2951 @@ +/* + * tclCmdIL.c -- + * + * This file contains the top-level command routines for most of + * the Tcl built-in commands whose names begin with the letters + * I through L. It contains only commands in the generic core + * (i.e. those that don't depend much upon UNIX facilities). + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1993-1997 Lucent Technologies. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" +#include "tclCompile.h" + +/* + * During execution of the "lsort" command, structures of the following + * type are used to arrange the objects being sorted into a collection + * of linked lists. + */ + +typedef struct SortElement { + Tcl_Obj *objPtr; /* Object being sorted. */ + struct SortElement *nextPtr; /* Next element in the list, or + * NULL for end of list. */ +} SortElement; + +/* + * The "lsort" command needs to pass certain information down to the + * function that compares two list elements, and the comparison function + * needs to pass success or failure information back up to the top-level + * "lsort" command. The following structure is used to pass this + * information. + */ + +typedef struct SortInfo { + int isIncreasing; /* Nonzero means sort in increasing order. */ + int sortMode; /* The sort mode. One of SORTMODE_* + * values defined below */ + Tcl_DString compareCmd; /* The Tcl comparison command when sortMode + * is SORTMODE_COMMAND. Pre-initialized to + * hold base of command.*/ + int index; /* If the -index option was specified, this + * holds the index of the list element + * to extract for comparison. If -index + * wasn't specified, this is -1. */ + Tcl_Interp *interp; /* The interpreter in which the sortis + * being done. */ + int resultCode; /* Completion code for the lsort command. + * If an error occurs during the sort this + * is changed from TCL_OK to TCL_ERROR. */ +} SortInfo; + +/* + * The "sortMode" field of the SortInfo structure can take on any of the + * following values. + */ + +#define SORTMODE_ASCII 0 +#define SORTMODE_INTEGER 1 +#define SORTMODE_REAL 2 +#define SORTMODE_COMMAND 3 +#define SORTMODE_DICTIONARY 4 + +/* + * Forward declarations for procedures defined in this file: + */ + +static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *listPtr, char *pattern, + int includeLinks)); +static int DictionaryCompare _ANSI_ARGS_((char *left, + char *right)); +static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoNameOfExecutableCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt, + SortInfo *infoPtr)); +static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr, + SortElement *rightPtr, SortInfo *infoPtr)); +static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr, + Tcl_Obj *second, SortInfo *infoPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_IfCmd -- + * + * This procedure is invoked to process the "if" Tcl command. + * See the user documentation for details on what it does. + * + * With the bytecode compiler, this procedure is only called when + * a command name is computed at runtime, and is "if" or the name + * to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}" + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_IfCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, result, value; + + i = 1; + while (1) { + /* + * At this point in the loop, argv and argc refer to an expression + * to test, either for the main expression or an expression + * following an "elseif". The arguments after the expression must + * be "then" (optional) and a script to execute if the expression is + * true. + */ + + if (i >= argc) { + Tcl_AppendResult(interp, "wrong # args: no expression after \"", + argv[i-1], "\" argument", (char *) NULL); + return TCL_ERROR; + } + result = Tcl_ExprBoolean(interp, argv[i], &value); + if (result != TCL_OK) { + return result; + } + i++; + if ((i < argc) && (strcmp(argv[i], "then") == 0)) { + i++; + } + if (i >= argc) { + Tcl_AppendResult(interp, "wrong # args: no script following \"", + argv[i-1], "\" argument", (char *) NULL); + return TCL_ERROR; + } + if (value) { + return Tcl_Eval(interp, argv[i]); + } + + /* + * The expression evaluated to false. Skip the command, then + * see if there is an "else" or "elseif" clause. + */ + + i++; + if (i >= argc) { + return TCL_OK; + } + if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) { + i++; + continue; + } + break; + } + + /* + * Couldn't find a "then" or "elseif" clause to execute. Check now + * for an "else" clause. We know that there's at least one more + * argument when we get here. + */ + + if (strcmp(argv[i], "else") == 0) { + i++; + if (i >= argc) { + Tcl_AppendResult(interp, + "wrong # args: no script following \"else\" argument", + (char *) NULL); + return TCL_ERROR; + } + } + return Tcl_Eval(interp, argv[i]); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IncrCmd -- + * + * This procedure is invoked to process the "incr" Tcl command. + * See the user documentation for details on what it does. + * + * With the bytecode compiler, this procedure is only called when + * a command name is computed at runtime, and is "incr" or the name + * to which "incr" was renamed: e.g., "set z incr; $z i -1" + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_IncrCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int value; + char *oldString, *result; + char newString[30]; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " varName ?increment?\"", (char *) NULL); + return TCL_ERROR; + } + + oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG); + if (oldString == NULL) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (reading value of variable to increment)"); + return TCL_ERROR; + } + if (argc == 2) { + value += 1; + } else { + int increment; + + if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (reading increment)"); + return TCL_ERROR; + } + value += increment; + } + TclFormatInt(newString, value); + result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG); + if (result == NULL) { + return TCL_ERROR; + } + + /* + * Copy the result since the variable's value might change. + */ + + Tcl_SetResult(interp, result, TCL_VOLATILE); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InfoObjCmd -- + * + * This procedure is invoked to process the "info" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_InfoObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Arbitrary value passed to the command. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + static char *subCmds[] = { + "args", "body", "cmdcount", "commands", + "complete", "default", "exists", "globals", + "hostname", "level", "library", "loaded", + "locals", "nameofexecutable", "patchlevel", "procs", + "script", "sharedlibextension", "tclversion", "vars", + (char *) NULL}; + enum ISubCmdIdx { + IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, + ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx, + IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, + ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, + IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx + } index; + int result; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } + + result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, + (int *) &index); + if (result != TCL_OK) { + return result; + } + + switch (index) { + case IArgsIdx: + result = InfoArgsCmd(clientData, interp, objc, objv); + break; + case IBodyIdx: + result = InfoBodyCmd(clientData, interp, objc, objv); + break; + case ICmdCountIdx: + result = InfoCmdCountCmd(clientData, interp, objc, objv); + break; + case ICommandsIdx: + result = InfoCommandsCmd(clientData, interp, objc, objv); + break; + case ICompleteIdx: + result = InfoCompleteCmd(clientData, interp, objc, objv); + break; + case IDefaultIdx: + result = InfoDefaultCmd(clientData, interp, objc, objv); + break; + case IExistsIdx: + result = InfoExistsCmd(clientData, interp, objc, objv); + break; + case IGlobalsIdx: + result = InfoGlobalsCmd(clientData, interp, objc, objv); + break; + case IHostnameIdx: + result = InfoHostnameCmd(clientData, interp, objc, objv); + break; + case ILevelIdx: + result = InfoLevelCmd(clientData, interp, objc, objv); + break; + case ILibraryIdx: + result = InfoLibraryCmd(clientData, interp, objc, objv); + break; + case ILoadedIdx: + result = InfoLoadedCmd(clientData, interp, objc, objv); + break; + case ILocalsIdx: + result = InfoLocalsCmd(clientData, interp, objc, objv); + break; + case INameOfExecutableIdx: + result = InfoNameOfExecutableCmd(clientData, interp, objc, objv); + break; + case IPatchLevelIdx: + result = InfoPatchLevelCmd(clientData, interp, objc, objv); + break; + case IProcsIdx: + result = InfoProcsCmd(clientData, interp, objc, objv); + break; + case IScriptIdx: + result = InfoScriptCmd(clientData, interp, objc, objv); + break; + case ISharedLibExtensionIdx: + result = InfoSharedlibCmd(clientData, interp, objc, objv); + break; + case ITclVersionIdx: + result = InfoTclVersionCmd(clientData, interp, objc, objv); + break; + case IVarsIdx: + result = InfoVarsCmd(clientData, interp, objc, objv); + break; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * InfoArgsCmd -- + * + * Called to implement the "info args" command that returns the + * argument list for a procedure. Handles the following syntax: + * + * info args procName + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoArgsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + char *name; + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *listObjPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procname"); + return TCL_ERROR; + } + + name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + procPtr = TclFindProc(iPtr, name); + if (procPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", name, "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; + } + + /* + * Build a return list containing the arguments. + */ + + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(localPtr->name, -1)); + } + } + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoBodyCmd -- + * + * Called to implement the "info body" command that returns the body + * for a procedure. Handles the following syntax: + * + * info body procName + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoBodyCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + char *name; + Proc *procPtr; + Tcl_Obj *bodyPtr, *resultPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procname"); + return TCL_ERROR; + } + + name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + procPtr = TclFindProc(iPtr, name); + if (procPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", name, "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; + } + + /* + * we need to check if the body from this procedure had been generated + * from a precompiled body. If that is the case, then the bodyPtr's + * string representation is bogus, since sources are not available. + * In order to make sure that later manipulations of the object do not + * invalidate the internal representation, we make a copy of the string + * representation and return that one, instead. + */ + + bodyPtr = procPtr->bodyPtr; + resultPtr = bodyPtr; + if (bodyPtr->typePtr == &tclByteCodeType) { + ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); + } + } + + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoCmdCountCmd -- + * + * Called to implement the "info cmdcount" command that returns the + * number of commands that have been executed. Handles the following + * syntax: + * + * info cmdcount + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoCmdCountCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoCommandsCmd -- + * + * Called to implement the "info commands" command that returns the + * list of commands in the interpreter that match an optional pattern. + * The pattern, if any, consists of an optional sequence of namespace + * names separated by "::" qualifiers, which is followed by a + * glob-style pattern that restricts which commands are returned. + * Handles the following syntax: + * + * info commands ?pattern? + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoCommandsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *cmdName, *pattern, *simplePattern; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Namespace *nsPtr; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Tcl_Obj *listPtr, *elemObjPtr; + int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ + Tcl_Command cmd; + int result; + + /* + * Get the pattern and find the "effective namespace" in which to + * list commands. + */ + + if (objc == 2) { + simplePattern = NULL; + nsPtr = currNsPtr; + specificNsInPattern = 0; + } else if (objc == 3) { + /* + * From the pattern, get the effective namespace and the simple + * pattern (no namespace qualifiers or ::'s) at the end. If an + * error was found while parsing the pattern, return it. Otherwise, + * if the namespace wasn't found, just leave nsPtr NULL: we will + * return an empty list since no commands there can be found. + */ + + Namespace *dummy1NsPtr, *dummy2NsPtr; + + pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + result = TclGetNamespaceForQualName(interp, pattern, + (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG, + &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + if (result != TCL_OK) { + return TCL_ERROR; + } + if (nsPtr != NULL) { /* we successfully found the pattern's ns */ + specificNsInPattern = (strcmp(simplePattern, pattern) != 0); + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + /* + * Scan through the effective namespace's command table and create a + * list with all commands that match the pattern. If a specific + * namespace was requested in the pattern, qualify the command names + * with the namespace name. + */ + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + if (nsPtr != NULL) { + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + if (specificNsInPattern) { + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + elemObjPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, cmd, elemObjPtr); + } else { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + entryPtr = Tcl_NextHashEntry(&search); + } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern, then add in + * all global :: commands that match the simple pattern. Of course, + * we add in only those commands that aren't hidden by a command in + * the effective namespace. + */ + + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cmdName, -1)); + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } + } + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoCompleteCmd -- + * + * Called to implement the "info complete" command that determines + * whether a string is a complete Tcl command. Handles the following + * syntax: + * + * info complete command + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoCompleteCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "command"); + return TCL_ERROR; + } + + if (TclObjCommandComplete(objv[2])) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoDefaultCmd -- + * + * Called to implement the "info default" command that returns the + * default value for a procedure argument. Handles the following + * syntax: + * + * info default procName arg varName + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoDefaultCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + char *procName, *argName, *varName; + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *valueObjPtr; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname"); + return TCL_ERROR; + } + + procName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + argName = Tcl_GetStringFromObj(objv[3], (int *) NULL); + + procPtr = TclFindProc(iPtr, procName); + if (procPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", procName, "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; + } + + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + if (TclIsVarArgument(localPtr) + && (strcmp(argName, localPtr->name) == 0)) { + if (localPtr->defValuePtr != NULL) { + valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, + localPtr->defValuePtr, 0); + if (valueObjPtr == NULL) { + defStoreError: + varName = Tcl_GetStringFromObj(objv[4], (int *) NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "couldn't store default value in variable \"", + varName, "\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_Obj *nullObjPtr = Tcl_NewObj(); + valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, + nullObjPtr, 0); + if (valueObjPtr == NULL) { + Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ + goto defStoreError; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + return TCL_OK; + } + } + + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, "\" doesn't have an argument \"", + argName, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoExistsCmd -- + * + * Called to implement the "info exists" command that determines + * whether a variable exists. Handles the following syntax: + * + * info exists varName + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoExistsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *varName; + Var *varPtr, *arrayPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varName"); + return TCL_ERROR; + } + + varName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + varPtr = TclLookupVar(interp, varName, (char *) NULL, + TCL_PARSE_PART1, "access", + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoGlobalsCmd -- + * + * Called to implement the "info globals" command that returns the list + * of global variables matching an optional pattern. Handles the + * following syntax: + * + * info globals ?pattern? + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoGlobalsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *varName, *pattern; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Var *varPtr; + Tcl_Obj *listPtr; + + if (objc == 2) { + pattern = NULL; + } else if (objc == 3) { + pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + /* + * Scan through the global :: namespace's variable table and create a + * list of all global variables that match the pattern. + */ + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (TclIsVarUndefined(varPtr)) { + continue; + } + varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr); + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(varName, -1)); + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoHostnameCmd -- + * + * Called to implement the "info hostname" command that returns the + * host name. Handles the following syntax: + * + * info hostname + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoHostnameCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *name; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + name = Tcl_GetHostName(); + if (name) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1); + return TCL_OK; + } else { + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "unable to determine name of host", -1); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * InfoLevelCmd -- + * + * Called to implement the "info level" command that returns + * information about the call stack. Handles the following syntax: + * + * info level ?number? + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoLevelCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + int level; + CallFrame *framePtr; + Tcl_Obj *listPtr; + + if (objc == 2) { /* just "info level" */ + if (iPtr->varFramePtr == NULL) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level); + } + return TCL_OK; + } else if (objc == 3) { + if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level <= 0) { + if (iPtr->varFramePtr == NULL) { + levelError: + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad level \"", + Tcl_GetStringFromObj(objv[2], (int *) NULL), + "\"", (char *) NULL); + return TCL_ERROR; + } + level += iPtr->varFramePtr->level; + } + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + + listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + + Tcl_WrongNumArgs(interp, 2, objv, "?number?"); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoLibraryCmd -- + * + * Called to implement the "info library" command that returns the + * library directory for the Tcl installation. Handles the following + * syntax: + * + * info library + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoLibraryCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *libDirName; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + if (libDirName != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1); + return TCL_OK; + } + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "no library has been specified for Tcl", -1); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoLoadedCmd -- + * + * Called to implement the "info loaded" command that returns the + * packages that have been loaded into an interpreter. Handles the + * following syntax: + * + * info loaded ?interp? + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoLoadedCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *interpName; + int result; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?interp?"); + return TCL_ERROR; + } + + if (objc == 2) { /* get loaded pkgs in all interpreters */ + interpName = NULL; + } else { /* get pkgs just in specified interp */ + interpName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + } + result = TclGetLoadedPackages(interp, interpName); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * InfoLocalsCmd -- + * + * Called to implement the "info locals" command to return a list of + * local variables that match an optional pattern. Handles the + * following syntax: + * + * info locals ?pattern? + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoLocalsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + char *pattern; + Tcl_Obj *listPtr; + + if (objc == 2) { + pattern = NULL; + } else if (objc == 3) { + pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) { + return TCL_OK; + } + + /* + * Return a list containing names of first the compiled locals (i.e. the + * ones stored in the call frame), then the variables in the local hash + * table (if one exists). + */ + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + AppendLocals(interp, listPtr, pattern, 0); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AppendLocals -- + * + * Append the local variables for the current frame to the + * specified list object. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AppendLocals(interp, listPtr, pattern, includeLinks) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Obj *listPtr; /* List object to append names to. */ + char *pattern; /* Pattern to match against. */ + int includeLinks; /* 1 if upvars should be included, else 0. */ +{ + Interp *iPtr = (Interp *) interp; + CompiledLocal *localPtr; + Var *varPtr; + int i, localVarCt; + char *varName; + Tcl_HashTable *localVarTablePtr; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + + localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr; + localVarCt = iPtr->varFramePtr->numCompiledLocals; + varPtr = iPtr->varFramePtr->compiledLocals; + localVarTablePtr = iPtr->varFramePtr->varTablePtr; + + for (i = 0; i < localVarCt; i++) { + /* + * Skip nameless (temporary) variables and undefined variables + */ + + if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) { + varName = varPtr->name; + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(varName, -1)); + } + } + varPtr++; + localPtr = localPtr->nextPtr; + } + + if (localVarTablePtr != NULL) { + for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (!TclIsVarUndefined(varPtr) + && (includeLinks || !TclIsVarLink(varPtr))) { + varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); + if ((pattern == NULL) + || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(varName, -1)); + } + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * InfoNameOfExecutableCmd -- + * + * Called to implement the "info nameofexecutable" command that returns + * the name of the binary file running this application. Handles the + * following syntax: + * + * info nameofexecutable + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoNameOfExecutableCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + CONST char *nameOfExecutable; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + nameOfExecutable = Tcl_GetNameOfExecutable(); + + if (nameOfExecutable != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *)nameOfExecutable, -1); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoPatchLevelCmd -- + * + * Called to implement the "info patchlevel" command that returns the + * default value for an argument to a procedure. Handles the following + * syntax: + * + * info patchlevel + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoPatchLevelCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *patchlevel; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); + if (patchlevel != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoProcsCmd -- + * + * Called to implement the "info procs" command that returns the + * procedures in the current namespace that match an optional pattern. + * Handles the following syntax: + * + * info procs ?pattern? + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoProcsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *cmdName, *pattern; + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Command *cmdPtr; + Tcl_Obj *listPtr; + + if (objc == 2) { + pattern = NULL; + } else if (objc == 3) { + pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + /* + * Scan through the current namespace's command table and return a list + * of all procs that match the pattern. + */ + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + for (entryPtr = Tcl_FirstHashEntry(&currNsPtr->cmdTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr); + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + if (TclIsProc(cmdPtr)) { + if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cmdName, -1)); + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoScriptCmd -- + * + * Called to implement the "info script" command that returns the + * script file that is currently being evaluated. Handles the + * following syntax: + * + * info script + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoScriptCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + if (iPtr->scriptFile != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoSharedlibCmd -- + * + * Called to implement the "info sharedlibextension" command that + * returns the file extension used for shared libraries. Handles the + * following syntax: + * + * info sharedlibextension + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoSharedlibCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + +#ifdef TCL_SHLIB_EXT + Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1); +#endif + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoTclVersionCmd -- + * + * Called to implement the "info tclversion" command that returns the + * version number for this Tcl library. Handles the following syntax: + * + * info tclversion + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoTclVersionCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *version; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + version = Tcl_GetVar(interp, "tcl_version", + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); + if (version != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * InfoVarsCmd -- + * + * Called to implement the "info vars" command that returns the + * list of variables in the interpreter that match an optional pattern. + * The pattern, if any, consists of an optional sequence of namespace + * names separated by "::" qualifiers, which is followed by a + * glob-style pattern that restricts which variables are returned. + * Handles the following syntax: + * + * info vars ?pattern? + * + * Results: + * Returns TCL_OK is successful and TCL_ERROR is there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoVarsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + char *varName, *pattern, *simplePattern; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Var *varPtr; + Namespace *nsPtr; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Tcl_Obj *listPtr, *elemObjPtr; + int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ + int result; + + /* + * Get the pattern and find the "effective namespace" in which to + * list variables. We only use this effective namespace if there's + * no active Tcl procedure frame. + */ + + if (objc == 2) { + simplePattern = NULL; + nsPtr = currNsPtr; + specificNsInPattern = 0; + } else if (objc == 3) { + /* + * From the pattern, get the effective namespace and the simple + * pattern (no namespace qualifiers or ::'s) at the end. If an + * error was found while parsing the pattern, return it. Otherwise, + * if the namespace wasn't found, just leave nsPtr NULL: we will + * return an empty list since no variables there can be found. + */ + + Namespace *dummy1NsPtr, *dummy2NsPtr; + + pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + result = TclGetNamespaceForQualName(interp, pattern, + (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG, + &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + if (result != TCL_OK) { + return TCL_ERROR; + } + if (nsPtr != NULL) { /* we successfully found the pattern's ns */ + specificNsInPattern = (strcmp(simplePattern, pattern) != 0); + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + /* + * If the namespace specified in the pattern wasn't found, just return. + */ + + if (nsPtr == NULL) { + return TCL_OK; + } + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + if ((iPtr->varFramePtr == NULL) + || !iPtr->varFramePtr->isProcCallFrame + || specificNsInPattern) { + /* + * There is no frame pointer, the frame pointer was pushed only + * to activate a namespace, or we are in a procedure call frame + * but a specific namespace was specified. Create a list containing + * only the variables in the effective namespace's variable table. + */ + + entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search); + while (entryPtr != NULL) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (!TclIsVarUndefined(varPtr) + || (varPtr->flags & VAR_NAMESPACE_VAR)) { + varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (specificNsInPattern) { + elemObjPtr = Tcl_NewObj(); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); + } else { + elemObjPtr = Tcl_NewStringObj(varName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern (i.e., the + * pattern only specifies variable names), then add in all global :: + * variables that match the simple pattern. Of course, add in only + * those variables that aren't hidden by a variable in the effective + * namespace. + */ + + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); + while (entryPtr != NULL) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + if (!TclIsVarUndefined(varPtr) + || (varPtr->flags & VAR_NAMESPACE_VAR)) { + varName = Tcl_GetHashKey(&globalNsPtr->varTable, + entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (Tcl_FindHashEntry(&nsPtr->varTable, varName) == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(varName, -1)); + } + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } + } else { + AppendLocals(interp, listPtr, simplePattern, 1); + } + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_JoinObjCmd -- + * + * This procedure is invoked to process the "join" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_JoinObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + char *joinString, *bytes; + int joinLength, listLen, length, i, result; + Tcl_Obj **elemPtrs; + Tcl_Obj *resObjPtr; + + if (objc == 2) { + joinString = " "; + joinLength = 1; + } else if (objc == 3) { + joinString = Tcl_GetStringFromObj(objv[2], &joinLength); + } else { + Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); + return TCL_ERROR; + } + + /* + * Make sure the list argument is a list object and get its length and + * a pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + + /* + * Now concatenate strings to form the "joined" result. We append + * directly into the interpreter's result object. + */ + + resObjPtr = Tcl_GetObjResult(interp); + + for (i = 0; i < listLen; i++) { + bytes = Tcl_GetStringFromObj(elemPtrs[i], &length); + if (i > 0) { + Tcl_AppendToObj(resObjPtr, joinString, joinLength); + } + Tcl_AppendToObj(resObjPtr, bytes, length); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LindexObjCmd -- + * + * This object-based procedure is invoked to process the "lindex" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LindexObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Obj *listPtr; + Tcl_Obj **elemPtrs; + int listLen, index, result; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "list index"); + return TCL_ERROR; + } + + /* + * Convert the first argument to a list if necessary. + */ + + listPtr = objv[1]; + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + + /* + * Get the index from objv[2]. + */ + + result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1), + &index); + if (result != TCL_OK) { + return result; + } + if ((index < 0) || (index >= listLen)) { + /* + * The index is out of range: the result is an empty string object. + */ + + return TCL_OK; + } + + /* + * Make sure listPtr still refers to a list object. It might have been + * converted to an int above if the argument objects were shared. + */ + + if (listPtr->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } + } + + /* + * Set the interpreter's object result to the index-th list element. + */ + + Tcl_SetObjResult(interp, elemPtrs[index]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinsertObjCmd -- + * + * This object-based procedure is invoked to process the "linsert" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A new Tcl list object formed by inserting zero or more elements + * into a list. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LinsertObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + register int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Obj *listPtr, *resultPtr; + Tcl_ObjType *typePtr; + int index, isDuplicate, len, result; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?"); + return TCL_ERROR; + } + + /* + * Get the index first since, if a conversion to int is needed, it + * will invalidate the list's internal representation. + */ + + result = TclGetIntForIndex(interp, objv[2], /*endValue*/ INT_MAX, + &index); + if (result != TCL_OK) { + return result; + } + + /* + * If the list object is unshared we can modify it directly. Otherwise + * we create a copy to modify: this is "copy on write". We create the + * duplicate directly in the interpreter's object result. + */ + + listPtr = objv[1]; + isDuplicate = 0; + if (Tcl_IsShared(listPtr)) { + /* + * The following code must reflect the logic in Tcl_DuplicateObj() + * except that it must duplicate the list object directly into the + * interpreter's result. + */ + + Tcl_ResetResult(interp); + resultPtr = Tcl_GetObjResult(interp); + typePtr = listPtr->typePtr; + if (listPtr->bytes == NULL) { + resultPtr->bytes = NULL; + } else if (listPtr->bytes != tclEmptyStringRep) { + len = listPtr->length; + TclInitStringRep(resultPtr, listPtr->bytes, len); + } + if (typePtr != NULL) { + if (typePtr->dupIntRepProc == NULL) { + resultPtr->internalRep = listPtr->internalRep; + resultPtr->typePtr = typePtr; + } else { + (*typePtr->dupIntRepProc)(listPtr, resultPtr); + } + } + listPtr = resultPtr; + isDuplicate = 1; + } + + if ((objc == 4) && (index == INT_MAX)) { + /* + * Special case: insert one element at the end of the list. + */ + + result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]); + } else if (objc > 3) { + result = Tcl_ListObjReplace(interp, listPtr, index, 0, + (objc-3), &(objv[3])); + } + if (result != TCL_OK) { + return result; + } + + /* + * Set the interpreter's object result. + */ + + if (!isDuplicate) { + Tcl_SetObjResult(interp, listPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListObjCmd -- + * + * This procedure is invoked to process the "list" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ListObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + register int objc; /* Number of arguments. */ + register Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + /* + * If there are no list elements, the result is an empty object. + * Otherwise modify the interpreter's result object to be a list object. + */ + + if (objc > 1) { + Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1])); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LlengthObjCmd -- + * + * This object-based procedure is invoked to process the "llength" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LlengthObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + register Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int listLen, result; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list"); + return TCL_ERROR; + } + + result = Tcl_ListObjLength(interp, objv[1], &listLen); + if (result != TCL_OK) { + return result; + } + + /* + * Set the interpreter's object result to an integer object holding the + * length. + */ + + Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LrangeObjCmd -- + * + * This procedure is invoked to process the "lrange" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LrangeObjCmd(notUsed, interp, objc, objv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + register Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Obj *listPtr; + Tcl_Obj **elemPtrs; + int listLen, first, last, numElems, result; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "list first last"); + return TCL_ERROR; + } + + /* + * Make sure the list argument is a list object and get its length and + * a pointer to its array of element pointers. + */ + + listPtr = objv[1]; + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + + /* + * Get the first and last indexes. + */ + + result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1), + &first); + if (result != TCL_OK) { + return result; + } + if (first < 0) { + first = 0; + } + + result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1), + &last); + if (result != TCL_OK) { + return result; + } + if (last >= listLen) { + last = (listLen - 1); + } + + if (first > last) { + return TCL_OK; /* the result is an empty object */ + } + + /* + * Make sure listPtr still refers to a list object. It might have been + * converted to an int above if the argument objects were shared. + */ + + if (listPtr->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } + } + + /* + * Extract a range of fields. We modify the interpreter's result object + * to be a list object containing the specified elements. + */ + + numElems = (last - first + 1); + Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first])); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LreplaceObjCmd -- + * + * This object-based procedure is invoked to process the "lreplace" + * Tcl command. See the user documentation for details on what it does. + * + * Results: + * A new Tcl list object formed by replacing zero or more elements of + * a list. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LreplaceObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Tcl_Obj *listPtr; + int createdNewObj, first, last, listLen, numToDelete; + int firstArgLen, result; + char *firstArg; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "list first last ?element element ...?"); + return TCL_ERROR; + } + + /* + * If the list object is unshared we can modify it directly, otherwise + * we create a copy to modify: this is "copy on write". + */ + + listPtr = objv[1]; + createdNewObj = 0; + if (Tcl_IsShared(listPtr)) { + listPtr = Tcl_DuplicateObj(listPtr); + createdNewObj = 1; + } + result = Tcl_ListObjLength(interp, listPtr, &listLen); + if (result != TCL_OK) { + errorReturn: + if (createdNewObj) { + Tcl_DecrRefCount(listPtr); /* free unneeded obj */ + } + return result; + } + + /* + * Get the first and last indexes. + */ + + result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1), + &first); + if (result != TCL_OK) { + goto errorReturn; + } + firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen); + + result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1), + &last); + if (result != TCL_OK) { + goto errorReturn; + } + + if (first < 0) { + first = 0; + } + if ((first >= listLen) && (listLen > 0) + && (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "list doesn't contain element ", + Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL); + result = TCL_ERROR; + goto errorReturn; + } + if (last >= listLen) { + last = (listLen - 1); + } + if (first <= last) { + numToDelete = (last - first + 1); + } else { + numToDelete = 0; + } + + if (objc > 4) { + result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, + (objc-4), &(objv[4])); + } else { + result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, + 0, NULL); + } + if (result != TCL_OK) { + goto errorReturn; + } + + /* + * Set the interpreter's object result. + */ + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsearchObjCmd -- + * + * This procedure is invoked to process the "lsearch" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LsearchObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument values. */ +{ +#define EXACT 0 +#define GLOB 1 +#define REGEXP 2 +#define DICTIONARY 3 +#define NOCASE 4 + char *bytes, *patternBytes; + int i, match, mode, index, result, listLen, length, elemLen; + Tcl_Obj **elemPtrs; + static char *switches[] = + {"-exact", "-glob", "-regexp", "-dictionary", "-nocase", (char *) NULL}; + + mode = GLOB; + if (objc == 4) { + if (Tcl_GetIndexFromObj(interp, objv[1], switches, + "search mode", 0, &mode) != TCL_OK) { + return TCL_ERROR; + } + } else if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?mode? list pattern"); + return TCL_ERROR; + } + + /* + * Make sure the list argument is a list object and get its length and + * a pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[objc-2], &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + + patternBytes = Tcl_GetStringFromObj(objv[objc-1], &length); + + index = -1; + for (i = 0; i < listLen; i++) { + match = 0; + bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen); + switch (mode) { + case EXACT: + if (length == elemLen) { + match = (memcmp(bytes, patternBytes, + (size_t) length) == 0); + } + break; + case GLOB: + /* + * WARNING: will not work with data containing NULLs. + */ + match = Tcl_StringMatch(bytes, patternBytes); + break; + case REGEXP: + /* + * WARNING: will not work with data containing NULLs. + */ + match = Tcl_RegExpMatch(interp, bytes, patternBytes); + if (match < 0) { + return TCL_ERROR; + } + break; + case DICTIONARY: + case NOCASE: +#if defined(__MSVC__) || defined(_MSC_VER) + match = strnicmp (bytes, patternBytes, length) == 0; +#else + match = strncasecmp (bytes, patternBytes, length) == 0; +#endif + break; + } + if (match) { + index = i; + break; + } + } + + Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsortObjCmd -- + * + * This procedure is invoked to process the "lsort" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LsortObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument values. */ +{ + int i, index, dummy; + Tcl_Obj *resultPtr; + int length; + Tcl_Obj *cmdPtr, **listObjPtrs; + SortElement *elementArray; + SortElement *elementPtr; + SortInfo sortInfo; /* Information about this sort that + * needs to be passed to the + * comparison function */ + static char *switches[] = + {"-ascii", "-command", "-decreasing", "-dictionary", + "-increasing", "-index", "-integer", "-real", (char *) NULL}; + + resultPtr = Tcl_GetObjResult(interp); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?options? list"); + return TCL_ERROR; + } + + /* + * Parse arguments to set up the mode for the sort. + */ + + sortInfo.isIncreasing = 1; + sortInfo.sortMode = SORTMODE_ASCII; + sortInfo.index = -1; + sortInfo.interp = interp; + sortInfo.resultCode = TCL_OK; + cmdPtr = NULL; + for (i = 1; i < objc-1; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case 0: /* -ascii */ + sortInfo.sortMode = SORTMODE_ASCII; + break; + case 1: /* -command */ + if (i == (objc-2)) { + Tcl_AppendToObj(resultPtr, + "\"-command\" option must be followed by comparison command", + -1); + return TCL_ERROR; + } + sortInfo.sortMode = SORTMODE_COMMAND; + cmdPtr = objv[i+1]; + i++; + break; + case 2: /* -decreasing */ + sortInfo.isIncreasing = 0; + break; + case 3: /* -dictionary */ + sortInfo.sortMode = SORTMODE_DICTIONARY; + break; + case 4: /* -increasing */ + sortInfo.isIncreasing = 1; + break; + case 5: /* -index */ + if (i == (objc-2)) { + Tcl_AppendToObj(resultPtr, + "\"-index\" option must be followed by list index", + -1); + return TCL_ERROR; + } + if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index) + != TCL_OK) { + return TCL_ERROR; + } + cmdPtr = objv[i+1]; + i++; + break; + case 6: /* -integer */ + sortInfo.sortMode = SORTMODE_INTEGER; + break; + case 7: /* -real */ + sortInfo.sortMode = SORTMODE_REAL; + break; + } + } + if (sortInfo.sortMode == SORTMODE_COMMAND) { + Tcl_DStringInit(&sortInfo.compareCmd); + Tcl_DStringAppend(&sortInfo.compareCmd, + Tcl_GetStringFromObj(cmdPtr, &dummy), -1); + } + + sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1], + &length, &listObjPtrs); + if (sortInfo.resultCode != TCL_OK) { + goto done; + } + if (length <= 0) { + return TCL_OK; + } + elementArray = (SortElement *) ckalloc(length * sizeof(SortElement)); + for (i=0; i < length; i++){ + elementArray[i].objPtr = listObjPtrs[i]; + elementArray[i].nextPtr = &elementArray[i+1]; + } + elementArray[length-1].nextPtr = NULL; + elementPtr = MergeSort(elementArray, &sortInfo); + if (sortInfo.resultCode == TCL_OK) { + /* + * Note: must clear the interpreter's result object: it could + * have been set by the -command script. + */ + + Tcl_ResetResult(interp); + resultPtr = Tcl_GetObjResult(interp); + for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){ + Tcl_ListObjAppendElement(interp, resultPtr, elementPtr->objPtr); + } + } + ckfree((char*) elementArray); + + done: + if (sortInfo.sortMode == SORTMODE_COMMAND) { + Tcl_DStringFree(&sortInfo.compareCmd); + } + return sortInfo.resultCode; +} + +/* + *---------------------------------------------------------------------- + * + * MergeSort - + * + * This procedure sorts a linked list of SortElement structures + * use the merge-sort algorithm. + * + * Results: + * A pointer to the head of the list after sorting is returned. + * + * Side effects: + * None, unless a user-defined comparison command does something + * weird. + * + *---------------------------------------------------------------------- + */ + +static SortElement * +MergeSort(headPtr, infoPtr) + SortElement *headPtr; /* First element on the list */ + SortInfo *infoPtr; /* Information needed by the + * comparison operator */ +{ + /* + * The subList array below holds pointers to temporary lists built + * during the merge sort. Element i of the array holds a list of + * length 2**i. + */ + +# define NUM_LISTS 30 + SortElement *subList[NUM_LISTS]; + SortElement *elementPtr; + int i; + + for(i = 0; i < NUM_LISTS; i++){ + subList[i] = NULL; + } + while (headPtr != NULL) { + elementPtr = headPtr; + headPtr = headPtr->nextPtr; + elementPtr->nextPtr = 0; + for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){ + elementPtr = MergeLists(subList[i], elementPtr, infoPtr); + subList[i] = NULL; + } + if (i >= NUM_LISTS) { + i = NUM_LISTS-1; + } + subList[i] = elementPtr; + } + elementPtr = NULL; + for (i = 0; i < NUM_LISTS; i++){ + elementPtr = MergeLists(subList[i], elementPtr, infoPtr); + } + return elementPtr; +} + +/* + *---------------------------------------------------------------------- + * + * MergeLists - + * + * This procedure combines two sorted lists of SortElement structures + * into a single sorted list. + * + * Results: + * The unified list of SortElement structures. + * + * Side effects: + * None, unless a user-defined comparison command does something + * weird. + * + *---------------------------------------------------------------------- + */ + +static SortElement * +MergeLists(leftPtr, rightPtr, infoPtr) + SortElement *leftPtr; /* First list to be merged; may be + * NULL. */ + SortElement *rightPtr; /* Second list to be merged; may be + * NULL. */ + SortInfo *infoPtr; /* Information needed by the + * comparison operator. */ +{ + SortElement *headPtr; + SortElement *tailPtr; + + if (leftPtr == NULL) { + return rightPtr; + } + if (rightPtr == NULL) { + return leftPtr; + } + if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) { + tailPtr = rightPtr; + rightPtr = rightPtr->nextPtr; + } else { + tailPtr = leftPtr; + leftPtr = leftPtr->nextPtr; + } + headPtr = tailPtr; + while ((leftPtr != NULL) && (rightPtr != NULL)) { + if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) { + tailPtr->nextPtr = rightPtr; + tailPtr = rightPtr; + rightPtr = rightPtr->nextPtr; + } else { + tailPtr->nextPtr = leftPtr; + tailPtr = leftPtr; + leftPtr = leftPtr->nextPtr; + } + } + if (leftPtr != NULL) { + tailPtr->nextPtr = leftPtr; + } else { + tailPtr->nextPtr = rightPtr; + } + return headPtr; +} + +/* + *---------------------------------------------------------------------- + * + * SortCompare -- + * + * This procedure is invoked by MergeLists to determine the proper + * ordering between two elements. + * + * Results: + * A negative results means the the first element comes before the + * second, and a positive results means that the second element + * should come first. A result of zero means the two elements + * are equal and it doesn't matter which comes first. + * + * Side effects: + * None, unless a user-defined comparison command does something + * weird. + * + *---------------------------------------------------------------------- + */ + +static int +SortCompare(objPtr1, objPtr2, infoPtr) + Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */ + SortInfo *infoPtr; /* Information passed from the + * top-level "lsort" command */ +{ + int order, dummy, listLen, index; + Tcl_Obj *objPtr; + char buffer[30]; + + order = 0; + if (infoPtr->resultCode != TCL_OK) { + /* + * Once an error has occurred, skip any future comparisons + * so as to preserve the error message in sortInterp->result. + */ + + return order; + } + if (infoPtr->index != -1) { + /* + * The "-index" option was specified. Treat each object as a + * list, extract the requested element from each list, and + * compare the elements, not the lists. The special index "end" + * is signaled here with a large negative index. + */ + + if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (infoPtr->index < -1) { + index = listLen - 1; + } else { + index = infoPtr->index; + } + + if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr) + != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (objPtr == NULL) { + objPtr = objPtr1; + missingElement: + sprintf(buffer, "%d", infoPtr->index); + Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), + "element ", buffer, " missing from sublist \"", + Tcl_GetStringFromObj(objPtr, (int *) NULL), + "\"", (char *) NULL); + infoPtr->resultCode = TCL_ERROR; + return order; + } + objPtr1 = objPtr; + + if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (infoPtr->index < -1) { + index = listLen - 1; + } else { + index = infoPtr->index; + } + + if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr) + != TCL_OK) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (objPtr == NULL) { + objPtr = objPtr2; + goto missingElement; + } + objPtr2 = objPtr; + } + if (infoPtr->sortMode == SORTMODE_ASCII) { + order = strcmp(Tcl_GetStringFromObj(objPtr1, &dummy), + Tcl_GetStringFromObj(objPtr2, &dummy)); + } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { + order = DictionaryCompare( + Tcl_GetStringFromObj(objPtr1, &dummy), + Tcl_GetStringFromObj(objPtr2, &dummy)); + } else if (infoPtr->sortMode == SORTMODE_INTEGER) { + int a, b; + + if ((Tcl_GetIntFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) + || (Tcl_GetIntFromObj(infoPtr->interp, objPtr2, &b) + != TCL_OK)) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (a > b) { + order = 1; + } else if (b > a) { + order = -1; + } + } else if (infoPtr->sortMode == SORTMODE_REAL) { + double a, b; + + if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) + || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b) + != TCL_OK)) { + infoPtr->resultCode = TCL_ERROR; + return order; + } + if (a > b) { + order = 1; + } else if (b > a) { + order = -1; + } + } else { + int oldLength; + + /* + * Generate and evaluate a command to determine which string comes + * first. + */ + + oldLength = Tcl_DStringLength(&infoPtr->compareCmd); + Tcl_DStringAppendElement(&infoPtr->compareCmd, + Tcl_GetStringFromObj(objPtr1, &dummy)); + Tcl_DStringAppendElement(&infoPtr->compareCmd, + Tcl_GetStringFromObj(objPtr2, &dummy)); + infoPtr->resultCode = Tcl_Eval(infoPtr->interp, + Tcl_DStringValue(&infoPtr->compareCmd)); + Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength); + if (infoPtr->resultCode != TCL_OK) { + Tcl_AddErrorInfo(infoPtr->interp, + "\n (-compare command)"); + return order; + } + + /* + * Parse the result of the command. + */ + + if (Tcl_GetIntFromObj(infoPtr->interp, + Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { + Tcl_ResetResult(infoPtr->interp); + Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp), + "-compare command returned non-numeric result", -1); + infoPtr->resultCode = TCL_ERROR; + return order; + } + } + if (!infoPtr->isIncreasing) { + order = -order; + } + return order; +} + +/* + *---------------------------------------------------------------------- + * + * DictionaryCompare + * + * This function compares two strings as if they were being used in + * an index or card catalog. The case of alphabetic characters is + * ignored, except to break ties. Thus "B" comes before "b" but + * after "a". Also, integers embedded in the strings compare in + * numerical order. In other words, "x10y" comes after "x9y", not + * before it as it would when using strcmp(). + * + * Results: + * A negative result means that the first element comes before the + * second, and a positive result means that the second element + * should come first. A result of zero means the two elements + * are equal and it doesn't matter which comes first. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DictionaryCompare(left, right) + char *left, *right; /* The strings to compare */ +{ + int diff, zeros; + int secondaryDiff = 0; + + while (1) { + if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) { + /* + * There are decimal numbers embedded in the two + * strings. Compare them as numbers, rather than + * strings. If one number has more leading zeros than + * the other, the number with more leading zeros sorts + * later, but only as a secondary choice. + */ + + zeros = 0; + while ((*right == '0') && (isdigit(UCHAR(right[1])))) { + right++; + zeros--; + } + while ((*left == '0') && (isdigit(UCHAR(left[1])))) { + left++; + zeros++; + } + if (secondaryDiff == 0) { + secondaryDiff = zeros; + } + + /* + * The code below compares the numbers in the two + * strings without ever converting them to integers. It + * does this by first comparing the lengths of the + * numbers and then comparing the digit values. + */ + + diff = 0; + while (1) { + if (diff == 0) { + diff = UCHAR(*left) - UCHAR(*right); + } + right++; + left++; + if (!isdigit(UCHAR(*right))) { + if (isdigit(UCHAR(*left))) { + return 1; + } else { + /* + * The two numbers have the same length. See + * if their values are different. + */ + + if (diff != 0) { + return diff; + } + break; + } + } else if (!isdigit(UCHAR(*left))) { + return -1; + } + } + continue; + } + diff = UCHAR(*left) - UCHAR(*right); + if (diff) { + if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) { + diff = UCHAR(tolower(*left)) - UCHAR(*right); + if (diff) { + return diff; + } else if (secondaryDiff == 0) { + secondaryDiff = -1; + } + } else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) { + diff = UCHAR(*left) - UCHAR(tolower(UCHAR(*right))); + if (diff) { + return diff; + } else if (secondaryDiff == 0) { + secondaryDiff = 1; + } + } else { + return diff; + } + } + if (*left == 0) { + break; + } + left++; + right++; + } + if (diff == 0) { + diff = secondaryDiff; + } + return diff; +} diff --git a/tcl/generic/tclCmdMZ.c b/tcl/generic/tclCmdMZ.c new file mode 100644 index 00000000000..87cfd108752 --- /dev/null +++ b/tcl/generic/tclCmdMZ.c @@ -0,0 +1,2186 @@ +/* + * tclCmdMZ.c -- + * + * This file contains the top-level command routines for most of + * the Tcl built-in commands whose names begin with the letters + * M to Z. It contains only commands in the generic core (i.e. + * those that don't depend much upon UNIX facilities). + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" +#include "tclCompile.h" + +/* + * Structure used to hold information about variable traces: + */ + +typedef struct { + int flags; /* Operations for which Tcl command is + * to be invoked. */ + char *errMsg; /* Error message returned from Tcl command, + * or NULL. Malloc'ed. */ + int length; /* Number of non-NULL chars. in command. */ + char command[4]; /* Space for Tcl command to invoke. Actual + * size will be as large as necessary to + * hold command. This field must be the + * last in the structure, so that it can + * be larger than 4 bytes. */ +} TraceVarInfo; + +/* + * Forward declarations for procedures defined in this file: + */ + +static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_PwdCmd -- + * + * This procedure is invoked to process the "pwd" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PwdCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *dirName; + + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], "\"", (char *) NULL); + return TCL_ERROR; + } + + dirName = TclGetCwd(interp); + if (dirName == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, dirName, TCL_VOLATILE); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegexpCmd -- + * + * This procedure is invoked to process the "regexp" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_RegexpCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int noCase = 0; + int indices = 0; + Tcl_RegExp regExpr; + char **argPtr, *string, *pattern, *start, *end; + int match = 0; /* Initialization needed only to + * prevent compiler warning. */ + int i; + Tcl_DString stringDString, patternDString; + + if (argc < 3) { + wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? exp string ?matchVar? ?subMatchVar ", + "subMatchVar ...?\"", (char *) NULL); + return TCL_ERROR; + } + argPtr = argv+1; + argc--; + while ((argc > 0) && (argPtr[0][0] == '-')) { + if (strcmp(argPtr[0], "-indices") == 0) { + indices = 1; + } else if (strcmp(argPtr[0], "-nocase") == 0) { + noCase = 1; + } else if (strcmp(argPtr[0], "--") == 0) { + argPtr++; + argc--; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argPtr[0], + "\": must be -indices, -nocase, or --", (char *) NULL); + return TCL_ERROR; + } + argPtr++; + argc--; + } + if (argc < 2) { + goto wrongNumArgs; + } + + /* + * Convert the string and pattern to lower case, if desired, and + * perform the matching operation. + */ + + if (noCase) { + register char *p; + + Tcl_DStringInit(&patternDString); + Tcl_DStringAppend(&patternDString, argPtr[0], -1); + pattern = Tcl_DStringValue(&patternDString); + for (p = pattern; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = (char)tolower(UCHAR(*p)); + } + } + Tcl_DStringInit(&stringDString); + Tcl_DStringAppend(&stringDString, argPtr[1], -1); + string = Tcl_DStringValue(&stringDString); + for (p = string; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = (char)tolower(UCHAR(*p)); + } + } + } else { + pattern = argPtr[0]; + string = argPtr[1]; + } + regExpr = Tcl_RegExpCompile(interp, pattern); + if (regExpr != NULL) { + match = Tcl_RegExpExec(interp, regExpr, string, string); + } + if (noCase) { + Tcl_DStringFree(&stringDString); + Tcl_DStringFree(&patternDString); + } + if (regExpr == NULL) { + return TCL_ERROR; + } + if (match < 0) { + return TCL_ERROR; + } + if (!match) { + Tcl_SetResult(interp, "0", TCL_STATIC); + return TCL_OK; + } + + /* + * If additional variable names have been specified, return + * index information in those variables. + */ + + argc -= 2; + for (i = 0; i < argc; i++) { + char *result, info[50]; + + Tcl_RegExpRange(regExpr, i, &start, &end); + if (start == NULL) { + if (indices) { + result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0); + } else { + result = Tcl_SetVar(interp, argPtr[i+2], "", 0); + } + } else { + if (indices) { + sprintf(info, "%d %d", (int)(start - string), + (int)(end - string - 1)); + result = Tcl_SetVar(interp, argPtr[i+2], info, 0); + } else { + char savedChar, *first, *last; + + first = argPtr[1] + (start - string); + last = argPtr[1] + (end - string); + if (first == last) { /* don't modify argument */ + result = Tcl_SetVar(interp, argPtr[i+2], "", 0); + } else { + savedChar = *last; + *last = 0; + result = Tcl_SetVar(interp, argPtr[i+2], first, 0); + *last = savedChar; + } + } + } + if (result == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + argPtr[i+2], "\"", (char *) NULL); + return TCL_ERROR; + } + } + Tcl_SetResult(interp, "1", TCL_STATIC); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegsubCmd -- + * + * This procedure is invoked to process the "regsub" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_RegsubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int noCase = 0, all = 0; + Tcl_RegExp regExpr; + char *string, *pattern, *p, *firstChar, **argPtr; + int match, code, numMatches; + char *start, *end, *subStart, *subEnd; + register char *src, c; + Tcl_DString stringDString, patternDString, resultDString; + + if (argc < 5) { + wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? exp string subSpec varName\"", (char *) NULL); + return TCL_ERROR; + } + argPtr = argv+1; + argc--; + while (argPtr[0][0] == '-') { + if (strcmp(argPtr[0], "-nocase") == 0) { + noCase = 1; + } else if (strcmp(argPtr[0], "-all") == 0) { + all = 1; + } else if (strcmp(argPtr[0], "--") == 0) { + argPtr++; + argc--; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argPtr[0], + "\": must be -all, -nocase, or --", (char *) NULL); + return TCL_ERROR; + } + argPtr++; + argc--; + } + if (argc != 4) { + goto wrongNumArgs; + } + + /* + * Convert the string and pattern to lower case, if desired. + */ + + if (noCase) { + Tcl_DStringInit(&patternDString); + Tcl_DStringAppend(&patternDString, argPtr[0], -1); + pattern = Tcl_DStringValue(&patternDString); + for (p = pattern; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = (char)tolower(UCHAR(*p)); + } + } + Tcl_DStringInit(&stringDString); + Tcl_DStringAppend(&stringDString, argPtr[1], -1); + string = Tcl_DStringValue(&stringDString); + for (p = string; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = (char)tolower(UCHAR(*p)); + } + } + } else { + pattern = argPtr[0]; + string = argPtr[1]; + } + Tcl_DStringInit(&resultDString); + regExpr = Tcl_RegExpCompile(interp, pattern); + if (regExpr == NULL) { + code = TCL_ERROR; + goto done; + } + + /* + * The following loop is to handle multiple matches within the + * same source string; each iteration handles one match and its + * corresponding substitution. If "-all" hasn't been specified + * then the loop body only gets executed once. + */ + + numMatches = 0; + for (p = string; *p != 0; ) { + match = Tcl_RegExpExec(interp, regExpr, p, string); + if (match < 0) { + code = TCL_ERROR; + goto done; + } + if (!match) { + break; + } + numMatches += 1; + + /* + * Copy the portion of the source string before the match to the + * result variable. + */ + + Tcl_RegExpRange(regExpr, 0, &start, &end); + Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), start - p); + + /* + * Append the subSpec argument to the variable, making appropriate + * substitutions. This code is a bit hairy because of the backslash + * conventions and because the code saves up ranges of characters in + * subSpec to reduce the number of calls to Tcl_SetVar. + */ + + for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) { + int index; + + if (c == '&') { + index = 0; + } else if (c == '\\') { + c = src[1]; + if ((c >= '0') && (c <= '9')) { + index = c - '0'; + } else if ((c == '\\') || (c == '&')) { + *src = c; + src[1] = 0; + Tcl_DStringAppend(&resultDString, firstChar, -1); + *src = '\\'; + src[1] = c; + firstChar = src+2; + src++; + continue; + } else { + continue; + } + } else { + continue; + } + if (firstChar != src) { + c = *src; + *src = 0; + Tcl_DStringAppend(&resultDString, firstChar, -1); + *src = c; + } + Tcl_RegExpRange(regExpr, index, &subStart, &subEnd); + if ((subStart != NULL) && (subEnd != NULL)) { + char *first, *last, saved; + + first = argPtr[1] + (subStart - string); + last = argPtr[1] + (subEnd - string); + saved = *last; + *last = 0; + Tcl_DStringAppend(&resultDString, first, -1); + *last = saved; + } + if (*src == '\\') { + src++; + } + firstChar = src+1; + } + if (firstChar != src) { + Tcl_DStringAppend(&resultDString, firstChar, -1); + } + if (end == p) { + + /* + * Always consume at least one character of the input string + * in order to prevent infinite loops. + */ + + Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), 1); + p = end + 1; + } else { + p = end; + } + if (!all) { + break; + } + } + + /* + * Copy the portion of the source string after the last match to the + * result variable. + */ + + if ((*p != 0) || (numMatches == 0)) { + Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), -1); + } + if (Tcl_SetVar(interp, argPtr[3], Tcl_DStringValue(&resultDString), 0) + == NULL) { + Tcl_AppendResult(interp, + "couldn't set variable \"", argPtr[3], "\"", + (char *) NULL); + code = TCL_ERROR; + } else { + char buf[40]; + + TclFormatInt(buf, numMatches); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + code = TCL_OK; + } + + done: + if (noCase) { + Tcl_DStringFree(&stringDString); + Tcl_DStringFree(&patternDString); + } + Tcl_DStringFree(&resultDString); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RenameObjCmd -- + * + * This procedure is invoked to process the "rename" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_RenameObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Arbitrary value passed to the command. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *oldName, *newName; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); + return TCL_ERROR; + } + + oldName = Tcl_GetStringFromObj(objv[1], (int *) NULL); + newName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + return TclRenameCommand(interp, oldName, newName); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReturnObjCmd -- + * + * This object-based procedure is invoked to process the "return" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ReturnObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + int optionLen, argLen, code, result; + + if (iPtr->errorInfo != NULL) { + ckfree(iPtr->errorInfo); + iPtr->errorInfo = NULL; + } + if (iPtr->errorCode != NULL) { + ckfree(iPtr->errorCode); + iPtr->errorCode = NULL; + } + code = TCL_OK; + + /* + * THIS FAILS IF AN OBJECT CONTAINS AN EMBEDDED NULL. + */ + + for (objv++, objc--; objc > 1; objv += 2, objc -= 2) { + char *option = Tcl_GetStringFromObj(objv[0], &optionLen); + char *arg = Tcl_GetStringFromObj(objv[1], &argLen); + + if (strcmp(option, "-code") == 0) { + register int c = arg[0]; + if ((c == 'o') && (strcmp(arg, "ok") == 0)) { + code = TCL_OK; + } else if ((c == 'e') && (strcmp(arg, "error") == 0)) { + code = TCL_ERROR; + } else if ((c == 'r') && (strcmp(arg, "return") == 0)) { + code = TCL_RETURN; + } else if ((c == 'b') && (strcmp(arg, "break") == 0)) { + code = TCL_BREAK; + } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) { + code = TCL_CONTINUE; + } else { + result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1], + &code); + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad completion code \"", + Tcl_GetStringFromObj(objv[1], (int *) NULL), + "\": must be ok, error, return, break, ", + "continue, or an integer", (char *) NULL); + return result; + } + } + } else if (strcmp(option, "-errorinfo") == 0) { + iPtr->errorInfo = + (char *) ckalloc((unsigned) (strlen(arg) + 1)); + strcpy(iPtr->errorInfo, arg); + } else if (strcmp(option, "-errorcode") == 0) { + iPtr->errorCode = + (char *) ckalloc((unsigned) (strlen(arg) + 1)); + strcpy(iPtr->errorCode, arg); + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", option, + "\": must be -code, -errorcode, or -errorinfo", + (char *) NULL); + return TCL_ERROR; + } + } + + if (objc == 1) { + /* + * Set the interpreter's object result. An inline version of + * Tcl_SetObjResult. + */ + + Tcl_SetObjResult(interp, objv[0]); + } + iPtr->returnCode = code; + return TCL_RETURN; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ScanCmd -- + * + * This procedure is invoked to process the "scan" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ScanCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +# define MAX_FIELDS 20 + typedef struct { + char fmt; /* Format for field. */ + int size; /* How many bytes to allow for + * field. */ + char *location; /* Where field will be stored. */ + } Field; + Field fields[MAX_FIELDS]; /* Info about all the fields in the + * format string. */ + register Field *curField; + int numFields = 0; /* Number of fields actually + * specified. */ + int suppress; /* Current field is assignment- + * suppressed. */ + int totalSize = 0; /* Number of bytes needed to store + * all results combined. */ + char *results; /* Where scanned output goes. + * Malloced; NULL means not allocated + * yet. */ + int numScanned; /* sscanf's result. */ + register char *fmt; + int i, widthSpecified, length, code; + char buf[40]; + + /* + * The variables below are used to hold a copy of the format + * string, so that we can replace format specifiers like "%f" + * and "%F" with specifiers like "%lf" + */ + +# define STATIC_SIZE 5 + char copyBuf[STATIC_SIZE], *fmtCopy; + register char *dst; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " string format ?varName varName ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * This procedure operates in four stages: + * 1. Scan the format string, collecting information about each field. + * 2. Allocate an array to hold all of the scanned fields. + * 3. Call sscanf to do all the dirty work, and have it store the + * parsed fields in the array. + * 4. Pick off the fields from the array and assign them to variables. + */ + + code = TCL_OK; + results = NULL; + length = strlen(argv[2]) * 2 + 1; + if (length < STATIC_SIZE) { + fmtCopy = copyBuf; + } else { + fmtCopy = (char *) ckalloc((unsigned) length); + } + dst = fmtCopy; + for (fmt = argv[2]; *fmt != 0; fmt++) { + *dst = *fmt; + dst++; + if (*fmt != '%') { + continue; + } + fmt++; + if (*fmt == '%') { + *dst = *fmt; + dst++; + continue; + } + if (*fmt == '*') { + suppress = 1; + *dst = *fmt; + dst++; + fmt++; + } else { + suppress = 0; + } + widthSpecified = 0; + while (isdigit(UCHAR(*fmt))) { + widthSpecified = 1; + *dst = *fmt; + dst++; + fmt++; + } + if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) { + fmt++; + } + *dst = *fmt; + dst++; + if (suppress) { + continue; + } + if (numFields == MAX_FIELDS) { + Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC); + code = TCL_ERROR; + goto done; + } + curField = &fields[numFields]; + numFields++; + switch (*fmt) { + case 'd': + case 'i': + case 'o': + case 'x': + curField->fmt = 'd'; + curField->size = sizeof(int); + break; + + case 'u': + curField->fmt = 'u'; + curField->size = sizeof(int); + break; + + case 's': + curField->fmt = 's'; + curField->size = strlen(argv[1]) + 1; + break; + + case 'c': + if (widthSpecified) { + Tcl_SetResult(interp, + "field width may not be specified in %c conversion", + TCL_STATIC); + code = TCL_ERROR; + goto done; + } + curField->fmt = 'c'; + curField->size = sizeof(int); + break; + + case 'e': + case 'f': + case 'g': + dst[-1] = 'l'; + dst[0] = 'f'; + dst++; + curField->fmt = 'f'; + curField->size = sizeof(double); + break; + + case '[': + curField->fmt = 's'; + curField->size = strlen(argv[1]) + 1; + do { + fmt++; + if (*fmt == 0) { + Tcl_SetResult(interp, + "unmatched [ in format string", TCL_STATIC); + code = TCL_ERROR; + goto done; + } + *dst = *fmt; + dst++; + } while (*fmt != ']'); + break; + + default: + { + char buf[50]; + + sprintf(buf, "bad scan conversion character \"%c\"", *fmt); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + code = TCL_ERROR; + goto done; + } + } + curField->size = TCL_ALIGN(curField->size); + totalSize += curField->size; + } + *dst = 0; + + if (numFields != (argc-3)) { + Tcl_SetResult(interp, + "different numbers of variable names and field specifiers", + TCL_STATIC); + code = TCL_ERROR; + goto done; + } + + /* + * Step 2: + */ + + results = (char *) ckalloc((unsigned) totalSize); + for (i = 0, totalSize = 0, curField = fields; + i < numFields; i++, curField++) { + curField->location = results + totalSize; + totalSize += curField->size; + } + + /* + * Fill in the remaining fields with NULL; the only purpose of + * this is to keep some memory analyzers, like Purify, from + * complaining. + */ + + for ( ; i < MAX_FIELDS; i++, curField++) { + curField->location = NULL; + } + + /* + * Step 3: + */ + + numScanned = sscanf(argv[1], fmtCopy, + fields[0].location, fields[1].location, fields[2].location, + fields[3].location, fields[4].location, fields[5].location, + fields[6].location, fields[7].location, fields[8].location, + fields[9].location, fields[10].location, fields[11].location, + fields[12].location, fields[13].location, fields[14].location, + fields[15].location, fields[16].location, fields[17].location, + fields[18].location, fields[19].location); + + /* + * Step 4: + */ + + if (numScanned < numFields) { + numFields = numScanned; + } + for (i = 0, curField = fields; i < numFields; i++, curField++) { + switch (curField->fmt) { + char string[TCL_DOUBLE_SPACE]; + + case 'd': + TclFormatInt(string, *((int *) curField->location)); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + storeError: + Tcl_AppendResult(interp, + "couldn't set variable \"", argv[i+3], "\"", + (char *) NULL); + code = TCL_ERROR; + goto done; + } + break; + + case 'u': + sprintf(string, "%u", *((int *) curField->location)); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + goto storeError; + } + break; + + case 'c': + TclFormatInt(string, *((char *) curField->location) & 0xff); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + goto storeError; + } + break; + + case 's': + if (Tcl_SetVar(interp, argv[i+3], curField->location, 0) + == NULL) { + goto storeError; + } + break; + + case 'f': + Tcl_PrintDouble((Tcl_Interp *) NULL, + *((double *) curField->location), string); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + goto storeError; + } + break; + } + } + TclFormatInt(buf, numScanned); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + done: + if (results != NULL) { + ckfree(results); + } + if (fmtCopy != copyBuf) { + ckfree(fmtCopy); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SourceObjCmd -- + * + * This procedure is invoked to process the "source" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SourceObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *bytes; + int result; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "fileName"); + return TCL_ERROR; + } + + /* + * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL. + */ + + bytes = Tcl_GetStringFromObj(objv[1], (int *) NULL); + result = Tcl_EvalFile(interp, bytes); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SplitObjCmd -- + * + * This procedure is invoked to process the "split" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SplitObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register char *p, *p2; + char *splitChars, *string, *elementStart; + int splitCharLen, stringLen, i, j; + Tcl_Obj *listPtr; + + if (objc == 2) { + splitChars = " \n\t\r"; + splitCharLen = 4; + } else if (objc == 3) { + splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); + } else { + Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); + return TCL_ERROR; + } + + string = Tcl_GetStringFromObj(objv[1], &stringLen); + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + /* + * Handle the special case of splitting on every character. + */ + + if (splitCharLen == 0) { + for (i = 0, p = string; i < stringLen; i++, p++) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(p, 1)); + } + } else { + /* + * Normal case: split on any of a given set of characters. + * Discard instances of the split characters. + */ + + for (i = 0, p = elementStart = string; i < stringLen; i++, p++) { + for (j = 0, p2 = splitChars; j < splitCharLen; j++, p2++) { + if (*p2 == *p) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(elementStart, (p-elementStart))); + elementStart = p+1; + break; + } + } + } + if (p != string) { + int remainingChars = stringLen - (elementStart-string); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(elementStart, remainingChars)); + } + } + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StringObjCmd -- + * + * This procedure is invoked to process the "string" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_StringObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int index, left, right; + Tcl_Obj *resultPtr; + char *string1, *string2; + int length1, length2; + static char *options[] = { + "compare", "first", "index", "last", + "length", "match", "range", "tolower", + "toupper", "trim", "trimleft", "trimright", + "wordend", "wordstart", NULL + }; + enum options { + STR_COMPARE, STR_FIRST, STR_INDEX, STR_LAST, + STR_LENGTH, STR_MATCH, STR_RANGE, STR_TOLOWER, + STR_TOUPPER, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, + STR_WORDEND, STR_WORDSTART + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + resultPtr = Tcl_GetObjResult(interp); + switch ((enum options) index) { + case STR_COMPARE: { + int match, length; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string1 string2"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + string2 = Tcl_GetStringFromObj(objv[3], &length2); + + length = (length1 < length2) ? length1 : length2; + match = memcmp(string1, string2, (unsigned) length); + if (match == 0) { + match = length1 - length2; + } + Tcl_SetIntObj(resultPtr, (match > 0) ? 1 : (match < 0) ? -1 : 0); + break; + } + case STR_FIRST: { + register char *p, *end; + int match; + + if (objc != 4) { + badFirstLastArgs: + Tcl_WrongNumArgs(interp, 2, objv, "string1 string2"); + return TCL_ERROR; + } + + match = -1; + string1 = Tcl_GetStringFromObj(objv[2], &length1); + string2 = Tcl_GetStringFromObj(objv[3], &length2); + if (length1 > 0) { + end = string2 + length2 - length1 + 1; + for (p = string2; p < end; p++) { + /* + * Scan forward to find the first character. + */ + + p = memchr(p, *string1, (unsigned) (end - p)); + if (p == NULL) { + break; + } + if (memcmp(string1, p, (unsigned) length1) == 0) { + match = p - string2; + break; + } + } + } + Tcl_SetIntObj(resultPtr, match); + break; + } + case STR_INDEX: { + int index; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + if ((index >= 0) && (index < length1)) { + Tcl_SetStringObj(resultPtr, string1 + index, 1); + } + break; + } + case STR_LAST: { + register char *p; + int match; + + if (objc != 4) { + goto badFirstLastArgs; + } + + match = -1; + string1 = Tcl_GetStringFromObj(objv[2], &length1); + string2 = Tcl_GetStringFromObj(objv[3], &length2); + if (length1 > 0) { + for (p = string2 + length2 - length1; p >= string2; p--) { + /* + * Scan backwards to find the first character. + */ + + while ((p != string2) && (*p != *string1)) { + p--; + } + if (memcmp(string1, p, (unsigned) length1) == 0) { + match = p - string2; + break; + } + } + } + Tcl_SetIntObj(resultPtr, match); + break; + } + case STR_LENGTH: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "string"); + return TCL_ERROR; + } + + (void) Tcl_GetStringFromObj(objv[2], &length1); + Tcl_SetIntObj(resultPtr, length1); + break; + } + case STR_MATCH: { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "pattern string"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + string2 = Tcl_GetStringFromObj(objv[3], &length2); + Tcl_SetBooleanObj(resultPtr, Tcl_StringMatch(string2, string1)); + break; + } + case STR_RANGE: { + int first, last; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "string first last"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + if (TclGetIntForIndex(interp, objv[3], length1 - 1, + &first) != TCL_OK) { + return TCL_ERROR; + } + if (TclGetIntForIndex(interp, objv[4], length1 - 1, + &last) != TCL_OK) { + return TCL_ERROR; + } + if (first < 0) { + first = 0; + } + if (last >= length1 - 1) { + last = length1 - 1; + } + if (last >= first) { + Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1); + } + break; + } + case STR_TOLOWER: { + register char *p, *end; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "string"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + + /* + * Since I know resultPtr is not a shared object, I can reach + * in and diddle the bytes in its string rep to convert them in + * place to lower case. + */ + + Tcl_SetStringObj(resultPtr, string1, length1); + string1 = Tcl_GetStringFromObj(resultPtr, &length1); + end = string1 + length1; + for (p = string1; p < end; p++) { + if (isupper(UCHAR(*p))) { + *p = (char) tolower(UCHAR(*p)); + } + } + break; + } + case STR_TOUPPER: { + register char *p, *end; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "string"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + + /* + * Since I know resultPtr is not a shared object, I can reach + * in and diddle the bytes in its string rep to convert them in + * place to upper case. + */ + + Tcl_SetStringObj(resultPtr, string1, length1); + string1 = Tcl_GetStringFromObj(resultPtr, &length1); + end = string1 + length1; + for (p = string1; p < end; p++) { + if (islower(UCHAR(*p))) { + *p = (char) toupper(UCHAR(*p)); + } + } + break; + } + case STR_TRIM: { + char ch; + register char *p, *end; + char *check, *checkEnd; + + left = 1; + right = 1; + + trim: + if (objc == 4) { + string2 = Tcl_GetStringFromObj(objv[3], &length2); + } else if (objc == 3) { + string2 = " \t\n\r"; + length2 = strlen(string2); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); + return TCL_ERROR; + } + string1 = Tcl_GetStringFromObj(objv[2], &length1); + checkEnd = string2 + length2; + + if (left) { + end = string1 + length1; + for (p = string1; p < end; p++) { + ch = *p; + for (check = string2; ; check++) { + if (check >= checkEnd) { + p = end; + break; + } + if (ch == *check) { + length1--; + string1++; + break; + } + } + } + } + if (right) { + end = string1; + for (p = string1 + length1; p > end; ) { + p--; + ch = *p; + for (check = string2; ; check++) { + if (check >= checkEnd) { + p = end; + break; + } + if (ch == *check) { + length1--; + break; + } + } + } + } + Tcl_SetStringObj(resultPtr, string1, length1); + break; + } + case STR_TRIMLEFT: { + left = 1; + right = 0; + goto trim; + } + case STR_TRIMRIGHT: { + left = 0; + right = 1; + goto trim; + } + case STR_WORDEND: { + int cur, c; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string index"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + if (index < 0) { + index = 0; + } + cur = length1; + if (index < length1) { + for (cur = index; cur < length1; cur++) { + c = UCHAR(string1[cur]); + if (!isalnum(c) && (c != '_')) { + break; + } + } + if (cur == index) { + cur = index + 1; + } + } + Tcl_SetIntObj(resultPtr, cur); + break; + } + case STR_WORDSTART: { + int cur, c; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string index"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + if (index >= length1) { + index = length1 - 1; + } + cur = 0; + if (index > 0) { + for (cur = index; cur >= 0; cur--) { + c = UCHAR(string1[cur]); + if (!isalnum(c) && (c != '_')) { + break; + } + } + if (cur != index) { + cur += 1; + } + } + Tcl_SetIntObj(resultPtr, cur); + break; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SubstCmd -- + * + * This procedure is invoked to process the "subst" Tcl command. + * See the user documentation for details on what it does. This + * command is an almost direct copy of an implementation by + * Andrew Payne. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SubstCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_DString result; + char *p, *old, *value; + int code, count, doVars, doCmds, doBackslashes, i; + size_t length; + char c; + + /* + * Parse command-line options. + */ + + doVars = doCmds = doBackslashes = 1; + for (i = 1; i < (argc-1); i++) { + p = argv[i]; + if (*p != '-') { + break; + } + length = strlen(p); + if (length < 4) { + badSwitch: + Tcl_AppendResult(interp, "bad switch \"", p, + "\": must be -nobackslashes, -nocommands, ", + "or -novariables", (char *) NULL); + return TCL_ERROR; + } + if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) { + doBackslashes = 0; + } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) { + doCmds = 0; + } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) { + doVars = 0; + } else { + goto badSwitch; + } + } + if (i != (argc-1)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?-nobackslashes? ?-nocommands? ?-novariables? string\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Scan through the string one character at a time, performing + * command, variable, and backslash substitutions. + */ + + Tcl_DStringInit(&result); + old = p = argv[i]; + while (*p != 0) { + switch (*p) { + case '\\': + if (doBackslashes) { + if (p != old) { + Tcl_DStringAppend(&result, old, p-old); + } + c = Tcl_Backslash(p, &count); + Tcl_DStringAppend(&result, &c, 1); + p += count; + old = p; + } else { + p++; + } + break; + + case '$': + if (doVars) { + if (p != old) { + Tcl_DStringAppend(&result, old, p-old); + } + value = Tcl_ParseVar(interp, p, &p); + if (value == NULL) { + Tcl_DStringFree(&result); + return TCL_ERROR; + } + Tcl_DStringAppend(&result, value, -1); + old = p; + } else { + p++; + } + break; + + case '[': + if (doCmds) { + if (p != old) { + Tcl_DStringAppend(&result, old, p-old); + } + iPtr->evalFlags = TCL_BRACKET_TERM; + code = Tcl_Eval(interp, p+1); + if (code == TCL_ERROR) { + Tcl_DStringFree(&result); + return code; + } + old = p = (p+1 + iPtr->termOffset+1); + Tcl_DStringAppend(&result, iPtr->result, -1); + Tcl_ResetResult(interp); + } else { + p++; + } + break; + + default: + p++; + break; + } + } + if (p != old) { + Tcl_DStringAppend(&result, old, p-old); + } + Tcl_DStringResult(interp, &result); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SwitchObjCmd -- + * + * This object-based procedure is invoked to process the "switch" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SwitchObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ +#define EXACT 0 +#define GLOB 1 +#define REGEXP 2 + int switchObjc, index; + Tcl_Obj *CONST *switchObjv; + Tcl_Obj *patternObj, *bodyObj; + char *string, *pattern, *body; + int splitObjs, length, patternLen, i, code, mode, matched, bodyIdx; + static char *switches[] = + {"-exact", "-glob", "-regexp", "--", (char *) NULL}; + + switchObjc = objc-1; + switchObjv = objv+1; + mode = EXACT; + + while (switchObjc > 0) { + string = Tcl_GetStringFromObj(switchObjv[0], &length); + if (*string != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, switchObjv[0], switches, + "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case 0: /* -exact */ + mode = EXACT; + break; + case 1: /* -glob */ + mode = GLOB; + break; + case 2: /* -regexp */ + mode = REGEXP; + break; + case 3: /* -- */ + switchObjc--; + switchObjv++; + goto doneWithSwitches; + } + switchObjc--; + switchObjv++; + } + + doneWithSwitches: + if (switchObjc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? string pattern body ... ?default body?"); + return TCL_ERROR; + } + + string = Tcl_GetStringFromObj(switchObjv[0], &length); + switchObjc--; + switchObjv++; + + /* + * If all of the pattern/command pairs are lumped into a single + * argument, split them out again. + */ + + splitObjs = 0; + if (switchObjc == 1) { + code = Tcl_ListObjLength(interp, switchObjv[0], &switchObjc); + if (code != TCL_OK) { + return code; + } + splitObjs = 1; + } + + for (i = 0; i < switchObjc; i += 2) { + if (i == (switchObjc-1)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "extra switch pattern with no body", -1); + code = TCL_ERROR; + goto done; + } + + /* + * See if the pattern matches the string. + */ + + if (splitObjs) { + code = Tcl_ListObjIndex(interp, switchObjv[0], i, &patternObj); + if (code != TCL_OK) { + return code; + } + pattern = Tcl_GetStringFromObj(patternObj, &patternLen); + } else { + pattern = Tcl_GetStringFromObj(switchObjv[i], &patternLen); + } + + matched = 0; + if ((*pattern == 'd') && (i == switchObjc-2) + && (strcmp(pattern, "default") == 0)) { + matched = 1; + } else { + /* + * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL. + */ + switch (mode) { + case EXACT: + matched = (strcmp(string, pattern) == 0); + break; + case GLOB: + matched = Tcl_StringMatch(string, pattern); + break; + case REGEXP: + matched = Tcl_RegExpMatch(interp, string, pattern); + if (matched < 0) { + code = TCL_ERROR; + goto done; + } + break; + } + } + if (!matched) { + continue; + } + + /* + * We've got a match. Find a body to execute, skipping bodies + * that are "-". + */ + + for (bodyIdx = i+1; ; bodyIdx += 2) { + if (bodyIdx >= switchObjc) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "no body specified for pattern \"", pattern, + "\"", (char *) NULL); + code = TCL_ERROR; + goto done; + } + + if (splitObjs) { + code = Tcl_ListObjIndex(interp, switchObjv[0], bodyIdx, + &bodyObj); + if (code != TCL_OK) { + return code; + } + } else { + bodyObj = switchObjv[bodyIdx]; + } + /* + * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL. + */ + body = Tcl_GetStringFromObj(bodyObj, &length); + if ((length != 1) || (body[0] != '-')) { + break; + } + } + code = Tcl_EvalObj(interp, bodyObj); + if (code == TCL_ERROR) { + char msg[100]; + sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern, + interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + goto done; + } + + /* + * Nothing matched: return nothing. + */ + + code = TCL_OK; + + done: + return code; +#undef EXACT +#undef GLOB +#undef REGEXP +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TimeObjCmd -- + * + * This object-based procedure is invoked to process the "time" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TimeObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Tcl_Obj *objPtr; + register int i, result; + int count; + double totalMicroSec; + Tcl_Time start, stop; + char buf[100]; + + if (objc == 2) { + count = 1; + } else if (objc == 3) { + result = Tcl_GetIntFromObj(interp, objv[2], &count); + if (result != TCL_OK) { + return result; + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); + return TCL_ERROR; + } + + objPtr = objv[1]; + i = count; + TclpGetTime(&start); + while (i-- > 0) { + result = Tcl_EvalObj(interp, objPtr); + if (result != TCL_OK) { + return result; + } + } + TclpGetTime(&stop); + + totalMicroSec = + (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + sprintf(buf, "%.0f microseconds per iteration", + ((count <= 0) ? 0 : totalMicroSec/count)); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceCmd -- + * + * This procedure is invoked to process the "trace" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TraceCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int c; + size_t length; + + if (argc < 2) { + Tcl_AppendResult(interp, "too few args: should be \"", + argv[0], " option [arg arg ...]\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][1]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0) + && (length >= 2)) { + char *p; + int flags, length; + TraceVarInfo *tvarPtr; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " variable name ops command\"", (char *) NULL); + return TCL_ERROR; + } + + flags = 0; + for (p = argv[3] ; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else { + goto badOps; + } + } + if (flags == 0) { + goto badOps; + } + + length = strlen(argv[4]); + tvarPtr = (TraceVarInfo *) ckalloc((unsigned) + (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); + tvarPtr->flags = flags; + tvarPtr->errMsg = NULL; + tvarPtr->length = length; + flags |= TCL_TRACE_UNSETS; + strcpy(tvarPtr->command, argv[4]); + if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc, + (ClientData) tvarPtr) != TCL_OK) { + ckfree((char *) tvarPtr); + return TCL_ERROR; + } + } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length) + && (length >= 2)) == 0) { + char *p; + int flags, length; + TraceVarInfo *tvarPtr; + ClientData clientData; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " vdelete name ops command\"", (char *) NULL); + return TCL_ERROR; + } + + flags = 0; + for (p = argv[3] ; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else { + goto badOps; + } + } + if (flags == 0) { + goto badOps; + } + + /* + * Search through all of our traces on this variable to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + length = strlen(argv[4]); + clientData = 0; + while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, + TraceVarProc, clientData)) != 0) { + tvarPtr = (TraceVarInfo *) clientData; + if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + && (strncmp(argv[4], tvarPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS, + TraceVarProc, clientData); + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + break; + } + } + } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0) + && (length >= 2)) { + ClientData clientData; + char ops[4], *p; + char *prefix = "{"; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " vinfo name\"", (char *) NULL); + return TCL_ERROR; + } + clientData = 0; + while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, + TraceVarProc, clientData)) != 0) { + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + p = ops; + if (tvarPtr->flags & TCL_TRACE_READS) { + *p = 'r'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + *p = 'w'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + *p = 'u'; + p++; + } + *p = '\0'; + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, ops); + Tcl_AppendElement(interp, tvarPtr->command); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be variable, vdelete, or vinfo", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + + badOps: + Tcl_AppendResult(interp, "bad operations \"", argv[3], + "\": should be one or more of rwu", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TraceVarProc -- + * + * This procedure is called to handle variable accesses that have + * been traced using the "trace" command. + * + * Results: + * Normally returns NULL. If the trace command returns an error, + * then this procedure returns an error string. + * + * Side effects: + * Depends on the command associated with the trace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +TraceVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about the variable trace. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable or array. */ + char *name2; /* Name of element within array; NULL means + * scalar variable is being referenced. */ + int flags; /* OR-ed bits giving operation and other + * information. */ +{ + Interp *iPtr = (Interp *) interp; + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + char *result; + int code; + Interp dummy; + Tcl_DString cmd; + Tcl_Obj *saveObjPtr, *oldObjResultPtr; + + result = NULL; + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + tvarPtr->errMsg = NULL; + } + if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + + /* + * Generate a command to execute by appending list elements + * for the two variable names and the operation. The five + * extra characters are for three space, the opcode character, + * and the terminating null. + */ + + if (name2 == NULL) { + name2 = ""; + } + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); + Tcl_DStringAppendElement(&cmd, name1); + Tcl_DStringAppendElement(&cmd, name2); + if (flags & TCL_TRACE_READS) { + Tcl_DStringAppend(&cmd, " r", 2); + } else if (flags & TCL_TRACE_WRITES) { + Tcl_DStringAppend(&cmd, " w", 2); + } else if (flags & TCL_TRACE_UNSETS) { + Tcl_DStringAppend(&cmd, " u", 2); + } + + /* + * Execute the command. Be careful to save and restore both the + * string and object results from the interpreter used for + * the command. We discard any object result the command returns. + */ + + dummy.objResultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(dummy.objResultPtr); + if (interp->freeProc == 0) { + dummy.freeProc = (Tcl_FreeProc *) 0; + dummy.result = ""; + Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, + TCL_VOLATILE); + } else { + dummy.freeProc = interp->freeProc; + dummy.result = interp->result; + interp->freeProc = (Tcl_FreeProc *) 0; + } + + saveObjPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(saveObjPtr); + + code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + if (code != TCL_OK) { /* copy error msg to result */ + tvarPtr->errMsg = (char *) + ckalloc((unsigned) (strlen(interp->result) + 1)); + strcpy(tvarPtr->errMsg, interp->result); + result = tvarPtr->errMsg; + Tcl_ResetResult(interp); /* must clear error state. */ + } + + /* + * Restore the interpreter's string result. + */ + + Tcl_SetResult(interp, dummy.result, + (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc); + + /* + * Restore the interpreter's object result from saveObjPtr. + */ + + oldObjResultPtr = iPtr->objResultPtr; + iPtr->objResultPtr = saveObjPtr; /* was incremented above */ + Tcl_DecrRefCount(oldObjResultPtr); + + Tcl_DecrRefCount(dummy.objResultPtr); + dummy.objResultPtr = NULL; + Tcl_DStringFree(&cmd); + } + if (flags & TCL_TRACE_DESTROYED) { + result = NULL; + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WhileCmd -- + * + * This procedure is invoked to process the "while" Tcl command. + * See the user documentation for details on what it does. + * + * With the bytecode compiler, this procedure is only called when + * a command name is computed at runtime, and is "while" or the name + * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}" + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_WhileCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int result, value; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " test command\"", (char *) NULL); + return TCL_ERROR; + } + + while (1) { + result = Tcl_ExprBoolean(interp, argv[1], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } + result = Tcl_Eval(interp, argv[2]); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"while\" body line %d)", + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + break; + } + } + if (result == TCL_BREAK) { + result = TCL_OK; + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + return result; +} + diff --git a/tcl/generic/tclCompExpr.c b/tcl/generic/tclCompExpr.c new file mode 100644 index 00000000000..d83752fe801 --- /dev/null +++ b/tcl/generic/tclCompExpr.c @@ -0,0 +1,2386 @@ +/* + * tclCompExpr.c -- + * + * This file contains the code to compile Tcl expressions. + * + * 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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclCompile.h" + +/* + * 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 arrange to use + * the errno from tclExecute.c here. + */ + +#ifndef TCL_GENERIC_ONLY +#include "tclPort.h" +#else +#define NO_ERRNO_H +#endif + +#ifdef NO_ERRNO_H +extern int errno; /* Use errno from tclExecute.c. */ +#define ERANGE 34 +#endif + +/* + * Boolean variable that controls whether expression compilation tracing + * is enabled. + */ + +#ifdef TCL_COMPILE_DEBUG +static int traceCompileExpr = 0; +#endif /* TCL_COMPILE_DEBUG */ + +/* + * The ExprInfo structure describes the state of compiling an expression. + * A pointer to an ExprInfo record is passed among the routines in + * this module. + */ + +typedef struct ExprInfo { + int token; /* Type of the last token parsed in expr. + * See below for definitions. Corresponds + * to the characters just before next. */ + int objIndex; /* If token is a literal value, the index of + * an object holding the value in the code's + * object table; otherwise is NULL. */ + char *funcName; /* If the token is FUNC_NAME, points to the + * first character of the math function's + * name; otherwise is NULL. */ + char *next; /* Position of the next character to be + * scanned in the expression string. */ + char *originalExpr; /* The entire expression that was originally + * passed to Tcl_ExprString et al. */ + char *lastChar; /* Pointer to terminating null in + * originalExpr. */ + int hasOperators; /* Set 1 if the expr has operators; 0 if + * expr is only a primary. If 1 after + * compiling an expr, a tryCvtToNumeric + * instruction is emitted to convert the + * primary to a number if possible. */ + int exprIsJustVarRef; /* Set 1 if the expr consists of just a + * variable reference as in the expression + * of "if $b then...". Otherwise 0. If 1 the + * expr is compiled out-of-line in order to + * implement expr's 2 level substitution + * semantics properly. */ + int exprIsComparison; /* Set 1 if the top-level operator in the + * expr is a comparison. Otherwise 0. If 1, + * because the operands might be strings, + * the expr is compiled out-of-line in order + * to implement expr's 2 level substitution + * semantics properly. */ +} ExprInfo; + +/* + * Definitions of the different tokens that appear in expressions. The order + * of these must match the corresponding entries in the operatorStrings + * array below. + */ + +#define LITERAL 0 +#define FUNC_NAME (LITERAL + 1) +#define OPEN_BRACKET (LITERAL + 2) +#define CLOSE_BRACKET (LITERAL + 3) +#define OPEN_PAREN (LITERAL + 4) +#define CLOSE_PAREN (LITERAL + 5) +#define DOLLAR (LITERAL + 6) +#define QUOTE (LITERAL + 7) +#define COMMA (LITERAL + 8) +#define END (LITERAL + 9) +#define UNKNOWN (LITERAL + 10) + +/* + * Binary operators: + */ + +#define MULT (UNKNOWN + 1) +#define DIVIDE (MULT + 1) +#define MOD (MULT + 2) +#define PLUS (MULT + 3) +#define MINUS (MULT + 4) +#define LEFT_SHIFT (MULT + 5) +#define RIGHT_SHIFT (MULT + 6) +#define LESS (MULT + 7) +#define GREATER (MULT + 8) +#define LEQ (MULT + 9) +#define GEQ (MULT + 10) +#define EQUAL (MULT + 11) +#define NEQ (MULT + 12) +#define BIT_AND (MULT + 13) +#define BIT_XOR (MULT + 14) +#define BIT_OR (MULT + 15) +#define AND (MULT + 16) +#define OR (MULT + 17) +#define QUESTY (MULT + 18) +#define COLON (MULT + 19) + +/* + * Unary operators. Unary minus and plus are represented by the (binary) + * tokens MINUS and PLUS. + */ + +#define NOT (COLON + 1) +#define BIT_NOT (NOT + 1) + +/* + * Mapping from tokens to strings; used for debugging messages. These + * entries must match the order and number of the token definitions above. + */ + +#ifdef TCL_COMPILE_DEBUG +static char *tokenStrings[] = { + "LITERAL", "FUNCNAME", + "[", "]", "(", ")", "$", "\"", ",", "END", "UNKNOWN", + "*", "/", "%", "+", "-", + "<<", ">>", "<", ">", "<=", ">=", "==", "!=", + "&", "^", "|", "&&", "||", "?", ":", + "!", "~" +}; +#endif /* TCL_COMPILE_DEBUG */ + +/* + * Declarations for local procedures to this file: + */ + +static int CompileAddExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompileBitAndExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompileBitOrExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompileBitXorExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompileCondExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompileEqualityExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompileLandExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompileLorExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompileMathFuncCall _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompileMultiplyExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompilePrimaryExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompileRelationalExpr _ANSI_ARGS_(( + Tcl_Interp *interp, ExprInfo *infoPtr, + int flags, CompileEnv *envPtr)); +static int CompileShiftExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int CompileUnaryExpr _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int flags, + CompileEnv *envPtr)); +static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, CompileEnv *envPtr)); + +/* + * Macro used to debug the execution of the recursive descent parser used + * to compile expressions. + */ + +#ifdef TCL_COMPILE_DEBUG +#define HERE(production, level) \ + if (traceCompileExpr) { \ + fprintf(stderr, "%*s%s: token=%s, next=\"%.20s\"\n", \ + (level), " ", (production), tokenStrings[infoPtr->token], \ + infoPtr->next); \ + } +#else +#define HERE(production, level) +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclCompileExpr -- + * + * This procedure compiles a string containing a Tcl expression into + * Tcl bytecodes. This procedure is the top-level interface to the + * the expression compilation module, and is used by such public + * procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, + * Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj. + * + * Note that the topmost recursive-descent parsing routine used by + * TclCompileExpr to compile expressions is called "CompileCondExpr" + * and not, e.g., "CompileExpr". This is done to avoid an extra + * procedure call since such a procedure would only return the result + * of calling CompileCondExpr. Other recursive-descent procedures + * that need to parse expressions also call CompileCondExpr. + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed; this might + * be the offset of the ']' (if flags & TCL_BRACKET_TERM), or the + * offset of the '\0' at the end of the string. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * envPtr->exprIsJustVarRef is set 1 if the expression consisted of + * a single variable reference as in the expression of "if $b then...". + * Otherwise it is set 0. This is used to implement Tcl's two level + * expression substitution semantics properly. + * + * envPtr->exprIsComparison is set 1 if the top-level operator in the + * expr is a comparison. Otherwise it is set 0. If 1, because the + * operands might be strings, the expr is compiled out-of-line in order + * to implement expr's 2 level substitution semantics properly. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileExpr(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Interp *iPtr = (Interp *) interp; + ExprInfo info; + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int result; + +#ifdef TCL_COMPILE_DEBUG + if (traceCompileExpr) { + fprintf(stderr, "expr: string=\"%.30s\"\n", string); + } +#endif /* TCL_COMPILE_DEBUG */ + + /* + * Register the builtin math functions the first time an expression is + * compiled. + */ + + if (!(iPtr->flags & EXPR_INITIALIZED)) { + BuiltinFunc *funcPtr; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; + int i; + + iPtr->flags |= EXPR_INITIALIZED; + i = 0; + for (funcPtr = builtinFuncTable; funcPtr->name != NULL; funcPtr++) { + Tcl_CreateMathFunc(interp, funcPtr->name, + funcPtr->numArgs, funcPtr->argTypes, + (Tcl_MathProc *) NULL, (ClientData) 0); + + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcPtr->name); + if (hPtr == NULL) { + panic("TclCompileExpr: Tcl_CreateMathFunc incorrectly registered '%s'", funcPtr->name); + return TCL_ERROR; + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + mathFuncPtr->builtinFuncIndex = i; + i++; + } + } + + info.token = UNKNOWN; + info.objIndex = -1; + info.funcName = NULL; + info.next = string; + info.originalExpr = string; + info.lastChar = lastChar; + info.hasOperators = 0; + info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */ + info.exprIsComparison = 0; /* set 1 if topmost operator is <,==,etc. */ + + /* + * Get the first token then compile an expression. + */ + + result = GetToken(interp, &info, envPtr); + if (result != TCL_OK) { + goto done; + } + + result = CompileCondExpr(interp, &info, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + if (info.token != END) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "syntax error in expression \"", string, "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (!info.hasOperators) { + /* + * Attempt to convert the primary's object to an int or double. + * This is done in order to support Tcl's policy of interpreting + * operands if at all possible as first integers, else + * floating-point numbers. + */ + + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); + } + maxDepth = envPtr->maxStackDepth; + + done: + envPtr->termOffset = (info.next - string); + envPtr->maxStackDepth = maxDepth; + envPtr->exprIsJustVarRef = info.exprIsJustVarRef; + envPtr->exprIsComparison = info.exprIsComparison; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileCondExpr -- + * + * This procedure compiles a Tcl conditional expression: + * condExpr ::= lorExpr ['?' condExpr ':' condExpr] + * + * Note that this is the topmost recursive-descent parsing routine used + * by TclCompileExpr to compile expressions. It does not call an + * separate, higher-level "CompileExpr" procedure. This avoids an extra + * procedure call since such a procedure would only return the result + * of calling CompileCondExpr. Other recursive-descent procedures that + * need to parse expressions also call CompileCondExpr. + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileCondExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; + /* Used to update or replace one-byte jumps + * around the then and else expressions when + * their target PCs are determined. */ + int elseCodeOffset, currCodeOffset, jumpDist, result; + + HERE("condExpr", 1); + result = CompileLorExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + + if (infoPtr->token == QUESTY) { + result = GetToken(interp, infoPtr, envPtr); /* skip over the '?' */ + if (result != TCL_OK) { + goto done; + } + + /* + * Emit the jump around the "then" clause to the "else" condExpr if + * the test was false. We emit a one byte (relative) jump here, and + * replace it later with a four byte jump if the jump target is more + * than 127 bytes away. + */ + + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); + + /* + * Compile the "then" expression. Note that if a subexpression + * is only a primary, we need to try to convert it to numeric. + * This is done in order to support Tcl's policy of interpreting + * operands if at all possible as first integers, else + * floating-point numbers. + */ + + infoPtr->hasOperators = 0; + infoPtr->exprIsJustVarRef = 0; + infoPtr->exprIsComparison = 0; + result = CompileCondExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + if (infoPtr->token != COLON) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "syntax error in expression \"", infoPtr->originalExpr, + "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (!infoPtr->hasOperators) { + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); + } + result = GetToken(interp, infoPtr, envPtr); /* skip over the ':' */ + if (result != TCL_OK) { + goto done; + } + + /* + * Emit an unconditional jump around the "else" condExpr. + */ + + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &jumpAroundElseFixup); + + /* + * Compile the "else" expression. + */ + + infoPtr->hasOperators = 0; + elseCodeOffset = TclCurrCodeOffset(); + result = CompileCondExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + if (!infoPtr->hasOperators) { + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); + } + + /* + * Fix up the second jump: the unconditional jump around the "else" + * expression. If the distance is too great (> 127 bytes), replace + * it with a four byte instruction and move the instructions after + * the jump down. + */ + + currCodeOffset = TclCurrCodeOffset(); + jumpDist = (currCodeOffset - jumpAroundElseFixup.codeOffset); + if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, jumpDist, 127)) { + /* + * Update the else expression's starting code offset since it + * moved down 3 bytes too. + */ + + elseCodeOffset += 3; + } + + /* + * Now fix up the first branch: the jumpFalse after the test. If the + * distance is too great, replace it with a four byte instruction + * and update the code offsets for the commands in both the "then" + * and "else" expressions. + */ + + jumpDist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); + TclFixupForwardJump(envPtr, &jumpAroundThenFixup, jumpDist, 127); + + infoPtr->hasOperators = 1; + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; + } + + done: + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileLorExpr -- + * + * This procedure compiles a Tcl logical or expression: + * lorExpr ::= landExpr {'||' landExpr} + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileLorExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth; /* Maximum number of stack elements needed + * to execute the expression. */ + JumpFixupArray jumpFixupArray; + /* Used to fix up the forward "short + * circuit" jump after each or-ed + * subexpression to just after the last + * subexpression. */ + JumpFixup jumpTrueFixup, jumpFixup; + /* Used to emit the jumps in the code to + * convert the first operand to a 0 or 1. */ + int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result; + Tcl_Obj *objPtr; + + HERE("lorExpr", 2); + result = CompileLandExpr(interp, infoPtr, flags, envPtr); + if ((result != TCL_OK) || (infoPtr->token != OR)) { + return result; /* envPtr->maxStackDepth is already set */ + } + + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + maxDepth = envPtr->maxStackDepth; + TclInitJumpFixupArray(&jumpFixupArray); + while (infoPtr->token == OR) { + result = GetToken(interp, infoPtr, envPtr); /* skip over the '||' */ + if (result != TCL_OK) { + goto done; + } + + if (jumpFixupArray.next == 0) { + /* + * Just the first "lor" operand is on the stack. The following + * is slightly ugly: we need to convert that first "lor" operand + * to a "0" or "1" to get the correct result if it is nonzero. + * Eventually we'll use a new instruction for this. + */ + + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup); + + objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, + /*inHeap*/ 0, envPtr); + objPtr = envPtr->objArrayPtr[objIndex]; + + Tcl_InvalidateStringRep(objPtr); + objPtr->internalRep.longValue = 0; + objPtr->typePtr = &tclIntType; + + TclEmitPush(objIndex, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + + jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset); + if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) { + panic("CompileLorExpr: bad jump distance %d\n", jumpDist); + } + objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, + /*inHeap*/ 0, envPtr); + objPtr = envPtr->objArrayPtr[objIndex]; + + Tcl_InvalidateStringRep(objPtr); + objPtr->internalRep.longValue = 1; + objPtr->typePtr = &tclIntType; + + TclEmitPush(objIndex, envPtr); + + jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); + if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { + panic("CompileLorExpr: bad jump distance %d\n", jumpDist); + } + } + + /* + * Duplicate the value on top of the stack to prevent the jump from + * consuming it. + */ + + TclEmitOpcode(INST_DUP, envPtr); + + /* + * Emit the "short circuit" jump around the rest of the lorExp if + * the previous expression was true. We emit a one byte (relative) + * jump here, and replace it later with a four byte jump if the jump + * target is more than 127 bytes away. + */ + + if (jumpFixupArray.next == jumpFixupArray.end) { + TclExpandJumpFixupArray(&jumpFixupArray); + } + fixupIndex = jumpFixupArray.next; + jumpFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, + &(jumpFixupArray.fixup[fixupIndex])); + + /* + * Compile the subexpression. + */ + + result = CompileLandExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + + /* + * Emit a "logical or" instruction. This does not try to "short- + * circuit" the evaluation of both operands of a Tcl "||" operator, + * but instead ensures that we either have a "1" or a "0" result. + */ + + TclEmitOpcode(INST_LOR, envPtr); + } + + /* + * Now that we know the target of the forward jumps, update the jumps + * with the correct distance. Also, if the distance is too great (> 127 + * bytes), replace the jump with a four byte instruction and move the + * instructions after the jump down. + */ + + for (j = jumpFixupArray.next; j > 0; j--) { + fixupIndex = (j - 1); /* process closest jump first */ + currCodeOffset = TclCurrCodeOffset(); + jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset); + TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127); + } + + /* + * We get here only if one or more ||'s appear as top-level operators. + */ + + done: + infoPtr->exprIsComparison = 0; + TclFreeJumpFixupArray(&jumpFixupArray); + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileLandExpr -- + * + * This procedure compiles a Tcl logical and expression: + * landExpr ::= bitOrExpr {'&&' bitOrExpr} + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileLandExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth; /* Maximum number of stack elements needed + * to execute the expression. */ + JumpFixupArray jumpFixupArray; + /* Used to fix up the forward "short + * circuit" jump after each and-ed + * subexpression to just after the last + * subexpression. */ + JumpFixup jumpTrueFixup, jumpFixup; + /* Used to emit the jumps in the code to + * convert the first operand to a 0 or 1. */ + int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result; + Tcl_Obj *objPtr; + + HERE("landExpr", 3); + result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); + if ((result != TCL_OK) || (infoPtr->token != AND)) { + return result; /* envPtr->maxStackDepth is already set */ + } + + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + maxDepth = envPtr->maxStackDepth; + TclInitJumpFixupArray(&jumpFixupArray); + while (infoPtr->token == AND) { + result = GetToken(interp, infoPtr, envPtr); /* skip over the '&&' */ + if (result != TCL_OK) { + goto done; + } + + if (jumpFixupArray.next == 0) { + /* + * Just the first "land" operand is on the stack. The following + * is slightly ugly: we need to convert the first "land" operand + * to a "0" or "1" to get the correct result if it is + * nonzero. Eventually we'll use a new instruction. + */ + + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup); + + objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, + /*inHeap*/ 0, envPtr); + objPtr = envPtr->objArrayPtr[objIndex]; + + Tcl_InvalidateStringRep(objPtr); + objPtr->internalRep.longValue = 0; + objPtr->typePtr = &tclIntType; + + TclEmitPush(objIndex, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + + jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset); + if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) { + panic("CompileLandExpr: bad jump distance %d\n", jumpDist); + } + objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, + /*inHeap*/ 0, envPtr); + objPtr = envPtr->objArrayPtr[objIndex]; + + Tcl_InvalidateStringRep(objPtr); + objPtr->internalRep.longValue = 1; + objPtr->typePtr = &tclIntType; + + TclEmitPush(objIndex, envPtr); + + jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); + if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { + panic("CompileLandExpr: bad jump distance %d\n", jumpDist); + } + } + + /* + * Duplicate the value on top of the stack to prevent the jump from + * consuming it. + */ + + TclEmitOpcode(INST_DUP, envPtr); + + /* + * Emit the "short circuit" jump around the rest of the landExp if + * the previous expression was false. We emit a one byte (relative) + * jump here, and replace it later with a four byte jump if the jump + * target is more than 127 bytes away. + */ + + if (jumpFixupArray.next == jumpFixupArray.end) { + TclExpandJumpFixupArray(&jumpFixupArray); + } + fixupIndex = jumpFixupArray.next; + jumpFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + &(jumpFixupArray.fixup[fixupIndex])); + + /* + * Compile the subexpression. + */ + + result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + + /* + * Emit a "logical and" instruction. This does not try to "short- + * circuit" the evaluation of both operands of a Tcl "&&" operator, + * but instead ensures that we either have a "1" or a "0" result. + */ + + TclEmitOpcode(INST_LAND, envPtr); + } + + /* + * Now that we know the target of the forward jumps, update the jumps + * with the correct distance. Also, if the distance is too great (> 127 + * bytes), replace the jump with a four byte instruction and move the + * instructions after the jump down. + */ + + for (j = jumpFixupArray.next; j > 0; j--) { + fixupIndex = (j - 1); /* process closest jump first */ + currCodeOffset = TclCurrCodeOffset(); + jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset); + TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), + jumpDist, 127); + } + + /* + * We get here only if one or more &&'s appear as top-level operators. + */ + + done: + infoPtr->exprIsComparison = 0; + TclFreeJumpFixupArray(&jumpFixupArray); + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileBitOrExpr -- + * + * This procedure compiles a Tcl bitwise or expression: + * bitOrExpr ::= bitXorExpr {'|' bitXorExpr} + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileBitOrExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int result; + + HERE("bitOrExpr", 4); + result = CompileBitXorExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + + while (infoPtr->token == BIT_OR) { + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + result = GetToken(interp, infoPtr, envPtr); /* skip over the '|' */ + if (result != TCL_OK) { + goto done; + } + + result = CompileBitXorExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + + TclEmitOpcode(INST_BITOR, envPtr); + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; + } + + done: + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileBitXorExpr -- + * + * This procedure compiles a Tcl bitwise exclusive or expression: + * bitXorExpr ::= bitAndExpr {'^' bitAndExpr} + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileBitXorExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int result; + + HERE("bitXorExpr", 5); + result = CompileBitAndExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + + while (infoPtr->token == BIT_XOR) { + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + result = GetToken(interp, infoPtr, envPtr); /* skip over the '^' */ + if (result != TCL_OK) { + goto done; + } + + result = CompileBitAndExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + + TclEmitOpcode(INST_BITXOR, envPtr); + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; + } + + done: + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileBitAndExpr -- + * + * This procedure compiles a Tcl bitwise and expression: + * bitAndExpr ::= equalityExpr {'&' equalityExpr} + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileBitAndExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int result; + + HERE("bitAndExpr", 6); + result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + + while (infoPtr->token == BIT_AND) { + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + result = GetToken(interp, infoPtr, envPtr); /* skip over the '&' */ + if (result != TCL_OK) { + goto done; + } + + result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + + TclEmitOpcode(INST_BITAND, envPtr); + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; + } + + done: + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileEqualityExpr -- + * + * This procedure compiles a Tcl equality (inequality) expression: + * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr} + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileEqualityExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int op, result; + + HERE("equalityExpr", 7); + result = CompileRelationalExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + + op = infoPtr->token; + while ((op == EQUAL) || (op == NEQ)) { + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + result = GetToken(interp, infoPtr, envPtr); /* skip over == or != */ + if (result != TCL_OK) { + goto done; + } + + result = CompileRelationalExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + + if (op == EQUAL) { + TclEmitOpcode(INST_EQ, envPtr); + } else { + TclEmitOpcode(INST_NEQ, envPtr); + } + + op = infoPtr->token; + + /* + * A comparison _is_ the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 1; + } + + done: + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileRelationalExpr -- + * + * This procedure compiles a Tcl relational expression: + * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr} + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileRelationalExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int op, result; + + HERE("relationalExpr", 8); + result = CompileShiftExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + + op = infoPtr->token; + while ((op == LESS) || (op == GREATER) || (op == LEQ) || (op == GEQ)) { + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + result = GetToken(interp, infoPtr, envPtr); /* skip over the op */ + if (result != TCL_OK) { + goto done; + } + + result = CompileShiftExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + + switch (op) { + case LESS: + TclEmitOpcode(INST_LT, envPtr); + break; + case GREATER: + TclEmitOpcode(INST_GT, envPtr); + break; + case LEQ: + TclEmitOpcode(INST_LE, envPtr); + break; + case GEQ: + TclEmitOpcode(INST_GE, envPtr); + break; + } + + op = infoPtr->token; + + /* + * A comparison _is_ the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 1; + } + + done: + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileShiftExpr -- + * + * This procedure compiles a Tcl shift expression: + * shiftExpr ::= addExpr {('<<' | '>>') addExpr} + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileShiftExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int op, result; + + HERE("shiftExpr", 9); + result = CompileAddExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + + op = infoPtr->token; + while ((op == LEFT_SHIFT) || (op == RIGHT_SHIFT)) { + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + result = GetToken(interp, infoPtr, envPtr); /* skip over << or >> */ + if (result != TCL_OK) { + goto done; + } + + result = CompileAddExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + + if (op == LEFT_SHIFT) { + TclEmitOpcode(INST_LSHIFT, envPtr); + } else { + TclEmitOpcode(INST_RSHIFT, envPtr); + } + + op = infoPtr->token; + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; + } + + done: + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileAddExpr -- + * + * This procedure compiles a Tcl addition expression: + * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr} + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileAddExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int op, result; + + HERE("addExpr", 10); + result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + + op = infoPtr->token; + while ((op == PLUS) || (op == MINUS)) { + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + result = GetToken(interp, infoPtr, envPtr); /* skip over + or - */ + if (result != TCL_OK) { + goto done; + } + + result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + + if (op == PLUS) { + TclEmitOpcode(INST_ADD, envPtr); + } else { + TclEmitOpcode(INST_SUB, envPtr); + } + + op = infoPtr->token; + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; + } + + done: + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileMultiplyExpr -- + * + * This procedure compiles a Tcl multiply expression: + * multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr} + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileMultiplyExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int op, result; + + HERE("multiplyExpr", 11); + result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + + op = infoPtr->token; + while ((op == MULT) || (op == DIVIDE) || (op == MOD)) { + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + result = GetToken(interp, infoPtr, envPtr); /* skip over * or / */ + if (result != TCL_OK) { + goto done; + } + + result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + + if (op == MULT) { + TclEmitOpcode(INST_MULT, envPtr); + } else if (op == DIVIDE) { + TclEmitOpcode(INST_DIV, envPtr); + } else { + TclEmitOpcode(INST_MOD, envPtr); + } + + op = infoPtr->token; + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; + } + + done: + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileUnaryExpr -- + * + * This procedure compiles a Tcl unary expression: + * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileUnaryExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int op, result; + + HERE("unaryExpr", 12); + op = infoPtr->token; + if ((op == PLUS) || (op == MINUS) || (op == BIT_NOT) || (op == NOT)) { + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + result = GetToken(interp, infoPtr, envPtr); /* skip over the op */ + if (result != TCL_OK) { + goto done; + } + + result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + + switch (op) { + case PLUS: + TclEmitOpcode(INST_UPLUS, envPtr); + break; + case MINUS: + TclEmitOpcode(INST_UMINUS, envPtr); + break; + case BIT_NOT: + TclEmitOpcode(INST_BITNOT, envPtr); + break; + case NOT: + TclEmitOpcode(INST_LNOT, envPtr); + break; + } + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; + } else { /* must be a primaryExpr */ + result = CompilePrimaryExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + } + + done: + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompilePrimaryExpr -- + * + * This procedure compiles a Tcl primary expression: + * primaryExpr ::= literal | varReference | quotedString | + * '[' command ']' | mathFuncCall | '(' condExpr ')' + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the expression. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompilePrimaryExpr(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int theToken; + char *dollarPtr, *quotePtr, *cmdPtr, *termPtr; + int result = TCL_OK; + + /* + * We emit tryCvtToNumeric instructions after most of these primary + * expressions in order to support Tcl's policy of interpreting operands + * as first integers if possible, otherwise floating-point numbers if + * possible. + */ + + HERE("primaryExpr", 13); + theToken = infoPtr->token; + + if ((theToken != DOLLAR) && (theToken != OPEN_PAREN)) { + infoPtr->exprIsJustVarRef = 0; + } + switch (theToken) { + case LITERAL: /* int, double, or string in braces */ + TclEmitPush(infoPtr->objIndex, envPtr); + maxDepth = 1; + break; + + case DOLLAR: /* $var variable reference */ + dollarPtr = (infoPtr->next - 1); + envPtr->pushSimpleWords = 1; + result = TclCompileDollarVar(interp, dollarPtr, + infoPtr->lastChar, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + infoPtr->next = (dollarPtr + envPtr->termOffset); + break; + + case QUOTE: /* quotedString */ + quotePtr = infoPtr->next; + envPtr->pushSimpleWords = 1; + result = TclCompileQuotes(interp, quotePtr, + infoPtr->lastChar, '"', flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + infoPtr->next = (quotePtr + envPtr->termOffset); + break; + + case OPEN_BRACKET: /* '[' command ']' */ + cmdPtr = infoPtr->next; + envPtr->pushSimpleWords = 1; + result = TclCompileString(interp, cmdPtr, + infoPtr->lastChar, (flags | TCL_BRACKET_TERM), envPtr); + if (result != TCL_OK) { + goto done; + } + termPtr = (cmdPtr + envPtr->termOffset); + if (*termPtr == ']') { + infoPtr->next = (termPtr + 1); /* advance over the ']'. */ + } else if (termPtr == infoPtr->lastChar) { + /* + * Missing ] at end of nested command. + */ + + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "missing close-bracket", -1); + result = TCL_ERROR; + goto done; + } else { + panic("CompilePrimaryExpr: unexpected termination char '%c' for nested command\n", *termPtr); + } + maxDepth = envPtr->maxStackDepth; + break; + + case FUNC_NAME: + result = CompileMathFuncCall(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + break; + + case OPEN_PAREN: + result = GetToken(interp, infoPtr, envPtr); /* skip over the '(' */ + if (result != TCL_OK) { + goto done; + } + infoPtr->exprIsComparison = 0; + result = CompileCondExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + if (infoPtr->token != CLOSE_PAREN) { + goto syntaxError; + } + break; + + default: + goto syntaxError; + } + + if (theToken != FUNC_NAME) { + /* + * Advance to the next token before returning. + */ + + result = GetToken(interp, infoPtr, envPtr); + if (result != TCL_OK) { + goto done; + } + } + + done: + envPtr->maxStackDepth = maxDepth; + return result; + + syntaxError: + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "syntax error in expression \"", infoPtr->originalExpr, + "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * CompileMathFuncCall -- + * + * This procedure compiles a call on a math function in an expression: + * mathFuncCall ::= funcName '(' [condExpr {',' condExpr}] ')' + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the function. + * + * Side effects: + * Adds instructions to envPtr to evaluate the math function at + * runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileMathFuncCall(interp, infoPtr, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Interp *iPtr = (Interp *) interp; + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + MathFunc *mathFuncPtr; /* Info about math function. */ + int objIndex; /* The object array index for an object + * holding the function name if it is not + * builtin. */ + Tcl_HashEntry *hPtr; + char *p, *funcName; + char savedChar; + int result, i; + + /* + * infoPtr->funcName points to the first character of the math + * function's name. Look for the end of its name and look up the + * MathFunc record for the function. + */ + + funcName = p = infoPtr->funcName; + while (isalnum(UCHAR(*p)) || (*p == '_')) { + p++; + } + infoPtr->next = p; + + result = GetToken(interp, infoPtr, envPtr); /* skip over func name */ + if (result != TCL_OK) { + goto done; + } + if (infoPtr->token != OPEN_PAREN) { + goto syntaxError; + } + result = GetToken(interp, infoPtr, envPtr); /* skip over '(' */ + if (result != TCL_OK) { + goto done; + } + + savedChar = *p; + *p = 0; + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown math function \"", funcName, "\"", (char *) NULL); + result = TCL_ERROR; + *p = savedChar; + goto done; + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + + /* + * If not a builtin function, push an object with the function's name. + */ + + if (mathFuncPtr->builtinFuncIndex < 0) { /* not builtin */ + objIndex = TclObjIndexForString(funcName, -1, /*allocStrRep*/ 1, + /*inHeap*/ 0, envPtr); + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + } + + /* + * Restore the saved character after the function name. + */ + + *p = savedChar; + + /* + * Compile the arguments for the function, if there are any. + */ + + if (mathFuncPtr->numArgs > 0) { + for (i = 0; ; i++) { + infoPtr->exprIsComparison = 0; + result = CompileCondExpr(interp, infoPtr, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + + /* + * Check for a ',' between arguments or a ')' ending the + * argument list. + */ + + if (i == (mathFuncPtr->numArgs-1)) { + if (infoPtr->token == CLOSE_PAREN) { + break; /* exit the argument parsing loop */ + } else if (infoPtr->token == COMMA) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many arguments for math function", -1); + result = TCL_ERROR; + goto done; + } else { + goto syntaxError; + } + } + if (infoPtr->token != COMMA) { + if (infoPtr->token == CLOSE_PAREN) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too few arguments for math function", -1); + result = TCL_ERROR; + goto done; + } else { + goto syntaxError; + } + } + result = GetToken(interp, infoPtr, envPtr); /* skip over , */ + if (result != TCL_OK) { + goto done; + } + maxDepth++; + } + } + + if (infoPtr->token != CLOSE_PAREN) { + goto syntaxError; + } + result = GetToken(interp, infoPtr, envPtr); /* skip over ')' */ + if (result != TCL_OK) { + goto done; + } + + /* + * Compile the call on the math function. Note that the "objc" argument + * count for non-builtin functions is incremented by 1 to include the + * the function name itself. + */ + + if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */ + TclEmitInstUInt1(INST_CALL_BUILTIN_FUNC1, + mathFuncPtr->builtinFuncIndex, envPtr); + } else { + TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); + } + + /* + * A comparison is not the top-level operator in this expression. + */ + + done: + infoPtr->exprIsComparison = 0; + envPtr->maxStackDepth = maxDepth; + return result; + + syntaxError: + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "syntax error in expression \"", infoPtr->originalExpr, + "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * GetToken -- + * + * Lexical scanner used to compile expressions: parses a single + * operator or other syntactic element from an expression string. + * + * Results: + * TCL_OK is returned unless an error occurred. In that case a standard + * Tcl error is returned, using the interpreter's result to hold an + * error message. TCL_ERROR is returned if an integer overflow, or a + * floating-point overflow or underflow occurred while reading in a + * number. If the lexical analysis is successful, infoPtr->token refers + * to the next symbol in the expression string, and infoPtr->next is + * advanced past the token. Also, if the token is a integer, double, or + * string literal, then infoPtr->objIndex the index of an object + * holding the value in the code's object table; otherwise is NULL. + * + * Side effects: + * Object are added to envPtr to hold the values of scanned literal + * integers, doubles, or strings. + * + *---------------------------------------------------------------------- + */ + +static int +GetToken(interp, infoPtr, envPtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + register ExprInfo *infoPtr; /* Describes the state of the + * compiling the expression, + * including the resulting token. */ + CompileEnv *envPtr; /* Holds objects that store literal + * values that are scanned. */ +{ + register char *src; /* Points to current source char. */ + register char c; /* The current char. */ + register int type; /* Current char's CHAR_TYPE type. */ + char *termPtr; /* Points to char terminating a literal. */ + char savedChar; /* Holds the character termporarily replaced + * by a null character during processing of + * literal tokens. */ + int objIndex; /* The object array index for an object + * holding a scanned literal. */ + long longValue; /* Value of a scanned integer literal. */ + double doubleValue; /* Value of a scanned double literal. */ + Tcl_Obj *objPtr; + + /* + * First initialize the scanner's "result" fields to default values. + */ + + infoPtr->token = UNKNOWN; + infoPtr->objIndex = -1; + infoPtr->funcName = NULL; + + /* + * Scan over leading white space at the start of a token. Note that a + * backslash-newline is treated as a space. + */ + + src = infoPtr->next; + c = *src; + type = CHAR_TYPE(src, infoPtr->lastChar); + while ((type & (TCL_SPACE | TCL_BACKSLASH)) || (c == '\n')) { + if (type == TCL_BACKSLASH) { + if (src[1] == '\n') { + src += 2; + } else { + break; /* no longer white space */ + } + } else { + src++; + } + c = *src; + type = CHAR_TYPE(src, infoPtr->lastChar); + } + if (src == infoPtr->lastChar) { + infoPtr->token = END; + infoPtr->next = src; + return TCL_OK; + } + + /* + * Try to parse the token first as an integer or floating-point + * number. Don't check for a number if the first character is "+" or + * "-". If we did, we might treat a binary operator as unary by mistake, + * which would eventually cause a syntax error. + */ + + if ((*src != '+') && (*src != '-')) { + int startsWithDigit = isdigit(UCHAR(*src)); + + if (startsWithDigit && TclLooksLikeInt(src)) { + errno = 0; + longValue = strtoul(src, &termPtr, 0); + if (errno == ERANGE) { + char *s = "integer value too large to represent"; + + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, + (char *) NULL); + return TCL_ERROR; + } + if (termPtr != src) { + /* + * src was the start of a valid integer. Find/create an + * object in envPtr's object array to contain the integer. + */ + + savedChar = *termPtr; + *termPtr = '\0'; + objIndex = TclObjIndexForString(src, termPtr - src, + /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); + *termPtr = savedChar; /* restore the saved char */ + + objPtr = envPtr->objArrayPtr[objIndex]; + Tcl_InvalidateStringRep(objPtr); + objPtr->internalRep.longValue = longValue; + objPtr->typePtr = &tclIntType; + + infoPtr->token = LITERAL; + infoPtr->objIndex = objIndex; + infoPtr->next = termPtr; + return TCL_OK; + } + } else if (startsWithDigit || (*src == '.') + || (*src == 'n') || (*src == 'N')) { + errno = 0; + doubleValue = strtod(src, &termPtr); + if (termPtr != src) { + if (errno != 0) { + TclExprFloatError(interp, doubleValue); + return TCL_ERROR; + } + + /* + * Find/create an object in the object array containing the + * double. + */ + + savedChar = *termPtr; + *termPtr = '\0'; + objIndex = TclObjIndexForString(src, termPtr - src, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + *termPtr = savedChar; /* restore the saved char */ + + objPtr = envPtr->objArrayPtr[objIndex]; + objPtr->internalRep.doubleValue = doubleValue; + objPtr->typePtr = &tclDoubleType; + + infoPtr->token = LITERAL; + infoPtr->objIndex = objIndex; + infoPtr->next = termPtr; + return TCL_OK; + } + } + } + + /* + * Not an integer or double literal. Check next for a string literal + * in braces. + */ + + if (*src == '{') { + int level = 0; /* The {} nesting level. */ + int hasBackslashNL = 0; /* Nonzero if '\newline' was found. */ + char *string = src; /* Set below to point just after the + * starting '{'. */ + char *last; /* Points just before terminating '}'. */ + int numChars; /* Number of chars in braced string. */ + char savedChar; /* Holds the character from string + * termporarily replaced by a null char + * during braced string processing. */ + int numRead; + + /* + * Check first for any backslash-newlines, since we must treat + * backslash-newlines specially (they must be replaced by spaces). + */ + + while (1) { + if (src == infoPtr->lastChar) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "missing close-brace", -1); + return TCL_ERROR; + } else if (CHAR_TYPE(src, infoPtr->lastChar) == TCL_NORMAL) { + src++; + continue; + } + c = *src++; + if (c == '{') { + level++; + } else if (c == '}') { + --level; + if (level == 0) { + last = (src - 2); /* i.e. just before terminating } */ + break; + } + } else if (c == '\\') { + if (*src == '\n') { + hasBackslashNL = 1; + } + (void) Tcl_Backslash(src-1, &numRead); + src += numRead - 1; + } + } + + /* + * Create a string object for the braced string. This will start at + * "string" and ends just after "last" (which points to the final + * character before the terminating '}'). If backslash-newlines were + * found, we copy characters one at a time into a heap-allocated + * buffer and do backslash-newline substitutions. + */ + + string++; + numChars = (last - string + 1); + savedChar = string[numChars]; + string[numChars] = '\0'; + if (hasBackslashNL && (numChars > 0)) { + char *buffer = ckalloc((unsigned) numChars + 1); + register char *dst = buffer; + register char *p = string; + while (p <= last) { + c = *dst++ = *p++; + if (c == '\\') { + if (*p == '\n') { + dst[-1] = Tcl_Backslash(p-1, &numRead); + p += numRead - 1; + } else { + (void) Tcl_Backslash(p-1, &numRead); + while (numRead > 1) { + *dst++ = *p++; + numRead--; + } + } + } + } + *dst = '\0'; + objIndex = TclObjIndexForString(buffer, dst - buffer, + /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); + } else { + objIndex = TclObjIndexForString(string, numChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + } + string[numChars] = savedChar; /* restore the saved char */ + + infoPtr->token = LITERAL; + infoPtr->objIndex = objIndex; + infoPtr->next = src; + return TCL_OK; + } + + /* + * Not an literal value. + */ + + infoPtr->next = src+1; /* assume a 1 char token and advance over it */ + switch (*src) { + case '[': + infoPtr->token = OPEN_BRACKET; + return TCL_OK; + + case ']': + infoPtr->token = CLOSE_BRACKET; + return TCL_OK; + + case '(': + infoPtr->token = OPEN_PAREN; + return TCL_OK; + + case ')': + infoPtr->token = CLOSE_PAREN; + return TCL_OK; + + case '$': + infoPtr->token = DOLLAR; + return TCL_OK; + + case '"': + infoPtr->token = QUOTE; + 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 (src[1]) { + case '<': + infoPtr->next = src+2; + infoPtr->token = LEFT_SHIFT; + break; + case '=': + infoPtr->next = src+2; + infoPtr->token = LEQ; + break; + default: + infoPtr->token = LESS; + break; + } + return TCL_OK; + + case '>': + switch (src[1]) { + case '>': + infoPtr->next = src+2; + infoPtr->token = RIGHT_SHIFT; + break; + case '=': + infoPtr->next = src+2; + infoPtr->token = GEQ; + break; + default: + infoPtr->token = GREATER; + break; + } + return TCL_OK; + + case '=': + if (src[1] == '=') { + infoPtr->next = src+2; + infoPtr->token = EQUAL; + } else { + infoPtr->token = UNKNOWN; + } + return TCL_OK; + + case '!': + if (src[1] == '=') { + infoPtr->next = src+2; + infoPtr->token = NEQ; + } else { + infoPtr->token = NOT; + } + return TCL_OK; + + case '&': + if (src[1] == '&') { + infoPtr->next = src+2; + infoPtr->token = AND; + } else { + infoPtr->token = BIT_AND; + } + return TCL_OK; + + case '^': + infoPtr->token = BIT_XOR; + return TCL_OK; + + case '|': + if (src[1] == '|') { + infoPtr->next = src+2; + infoPtr->token = OR; + } else { + infoPtr->token = BIT_OR; + } + return TCL_OK; + + case '~': + infoPtr->token = BIT_NOT; + return TCL_OK; + + default: + if (isalpha(UCHAR(*src))) { + infoPtr->token = FUNC_NAME; + infoPtr->funcName = src; + while (isalnum(UCHAR(*src)) || (*src == '_')) { + src++; + } + infoPtr->next = src; + return TCL_OK; + } + infoPtr->next = src+1; + infoPtr->token = UNKNOWN; + return TCL_OK; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateMathFunc -- + * + * Creates a new math function for expressions in a given + * interpreter. + * + * Results: + * None. + * + * Side effects: + * The function defined by "name" is created or redefined. If the + * function already exists then its definition is replaced; this + * includes the builtin functions. Redefining a builtin function forces + * all existing code to be invalidated since that code may be compiled + * using an instruction specific to the replaced function. In addition, + * redefioning a non-builtin function will force existing code to be + * invalidated if the number of arguments has changed. + * + *---------------------------------------------------------------------- + */ + +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 (!new) { + if (mathFuncPtr->builtinFuncIndex >= 0) { + /* + * We are redefining a builtin math function. Invalidate the + * interpreter's existing code by incrementing its + * compileEpoch member. This field is checked in Tcl_EvalObj + * and ObjInterpProc, and code whose compilation epoch doesn't + * match is recompiled. Newly compiled code will no longer + * treat the function as builtin. + */ + + iPtr->compileEpoch++; + } else { + /* + * A non-builtin function is being redefined. We must invalidate + * existing code if the number of arguments has changed. This + * is because existing code was compiled assuming that number. + */ + + if (numArgs != mathFuncPtr->numArgs) { + iPtr->compileEpoch++; + } + } + } + + mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ + 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; +} diff --git a/tcl/generic/tclCompile.c b/tcl/generic/tclCompile.c new file mode 100644 index 00000000000..a6220af88ee --- /dev/null +++ b/tcl/generic/tclCompile.c @@ -0,0 +1,8089 @@ +/* + * tclCompile.c -- + * + * This file contains procedures that compile Tcl commands or parts + * of commands (like quoted strings or nested sub-commands) into a + * sequence of instructions ("bytecodes"). + * + * 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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclCompile.h" + +/* + * Variable that controls whether compilation tracing is enabled and, if so, + * what level of tracing is desired: + * 0: no compilation tracing + * 1: summarize compilation of top level cmds and proc bodies + * 2: display all instructions of each ByteCode compiled + * This variable is linked to the Tcl variable "tcl_traceCompile". + */ + +int tclTraceCompile = 0; +static int traceInitialized = 0; + +/* + * Count of the number of compilations and various other compilation- + * related statistics. + */ + +#ifdef TCL_COMPILE_STATS +long tclNumCompilations = 0; +double tclTotalSourceBytes = 0.0; +double tclTotalCodeBytes = 0.0; + +double tclTotalInstBytes = 0.0; +double tclTotalObjBytes = 0.0; +double tclTotalExceptBytes = 0.0; +double tclTotalAuxBytes = 0.0; +double tclTotalCmdMapBytes = 0.0; + +double tclCurrentSourceBytes = 0.0; +double tclCurrentCodeBytes = 0.0; + +int tclSourceCount[32]; +int tclByteCodeCount[32]; +#endif /* TCL_COMPILE_STATS */ + +/* + * A table describing the Tcl bytecode instructions. The entries in this + * table must correspond to the list of instructions in tclInt.h. The names + * "op1" and "op4" refer to an instruction's one or four byte first operand. + * Similarly, "stktop" and "stknext" refer to the topmost and next to + * topmost stack elements. + * + * Note that the load, store, and incr instructions do not distinguish local + * from global variables; the bytecode interpreter at runtime uses the + * existence of a procedure call frame to distinguish these. + */ + +InstructionDesc instructionTable[] = { + /* Name Bytes #Opnds Operand types Stack top, next */ + {"done", 1, 0, {OPERAND_NONE}}, + /* Finish ByteCode execution and return stktop (top stack item) */ + {"push1", 2, 1, {OPERAND_UINT1}}, + /* Push object at ByteCode objArray[op1] */ + {"push4", 5, 1, {OPERAND_UINT4}}, + /* Push object at ByteCode objArray[op4] */ + {"pop", 1, 0, {OPERAND_NONE}}, + /* Pop the topmost stack object */ + {"dup", 1, 0, {OPERAND_NONE}}, + /* Duplicate the topmost stack object and push the result */ + {"concat1", 2, 1, {OPERAND_UINT1}}, + /* Concatenate the top op1 items and push result */ + {"invokeStk1", 2, 1, {OPERAND_UINT1}}, + /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ + {"invokeStk4", 5, 1, {OPERAND_UINT4}}, + /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */ + {"evalStk", 1, 0, {OPERAND_NONE}}, + /* Evaluate command in stktop using Tcl_EvalObj. */ + {"exprStk", 1, 0, {OPERAND_NONE}}, + /* Execute expression in stktop using Tcl_ExprStringObj. */ + + {"loadScalar1", 2, 1, {OPERAND_UINT1}}, + /* Load scalar variable at index op1 <= 255 in call frame */ + {"loadScalar4", 5, 1, {OPERAND_UINT4}}, + /* Load scalar variable at index op1 >= 256 in call frame */ + {"loadScalarStk", 1, 0, {OPERAND_NONE}}, + /* Load scalar variable; scalar's name is stktop */ + {"loadArray1", 2, 1, {OPERAND_UINT1}}, + /* Load array element; array at slot op1<=255, element is stktop */ + {"loadArray4", 5, 1, {OPERAND_UINT4}}, + /* Load array element; array at slot op1 > 255, element is stktop */ + {"loadArrayStk", 1, 0, {OPERAND_NONE}}, + /* Load array element; element is stktop, array name is stknext */ + {"loadStk", 1, 0, {OPERAND_NONE}}, + /* Load general variable; unparsed variable name is stktop */ + {"storeScalar1", 2, 1, {OPERAND_UINT1}}, + /* Store scalar variable at op1<=255 in frame; value is stktop */ + {"storeScalar4", 5, 1, {OPERAND_UINT4}}, + /* Store scalar variable at op1 > 255 in frame; value is stktop */ + {"storeScalarStk", 1, 0, {OPERAND_NONE}}, + /* Store scalar; value is stktop, scalar name is stknext */ + {"storeArray1", 2, 1, {OPERAND_UINT1}}, + /* Store array element; array at op1<=255, value is top then elem */ + {"storeArray4", 5, 1, {OPERAND_UINT4}}, + /* Store array element; array at op1>=256, value is top then elem */ + {"storeArrayStk", 1, 0, {OPERAND_NONE}}, + /* Store array element; value is stktop, then elem, array names */ + {"storeStk", 1, 0, {OPERAND_NONE}}, + /* Store general variable; value is stktop, then unparsed name */ + + {"incrScalar1", 2, 1, {OPERAND_UINT1}}, + /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ + {"incrScalarStk", 1, 0, {OPERAND_NONE}}, + /* Incr scalar; incr amount is stktop, scalar's name is stknext */ + {"incrArray1", 2, 1, {OPERAND_UINT1}}, + /* Incr array elem; arr at slot op1<=255, amount is top then elem */ + {"incrArrayStk", 1, 0, {OPERAND_NONE}}, + /* Incr array element; amount is top then elem then array names */ + {"incrStk", 1, 0, {OPERAND_NONE}}, + /* Incr general variable; amount is stktop then unparsed var name */ + {"incrScalar1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}}, + /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ + {"incrScalarStkImm", 2, 1, {OPERAND_INT1}}, + /* Incr scalar; scalar name is stktop; incr amount is op1 */ + {"incrArray1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}}, + /* Incr array elem; array at slot op1 <= 255, elem is stktop, + * amount is 2nd operand byte */ + {"incrArrayStkImm", 2, 1, {OPERAND_INT1}}, + /* Incr array element; elem is top then array name, amount is op1 */ + {"incrStkImm", 2, 1, {OPERAND_INT1}}, + /* Incr general variable; unparsed name is top, amount is op1 */ + + {"jump1", 2, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) */ + {"jump4", 5, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) */ + {"jumpTrue1", 2, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) if stktop expr object is true */ + {"jumpTrue4", 5, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) if stktop expr object is true */ + {"jumpFalse1", 2, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) if stktop expr object is false */ + {"jumpFalse4", 5, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) if stktop expr object is false */ + + {"lor", 1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"land", 1, 0, {OPERAND_NONE}}, + /* Logical and: push (stknext && stktop) */ + {"bitor", 1, 0, {OPERAND_NONE}}, + /* Bitwise or: push (stknext | stktop) */ + {"bitxor", 1, 0, {OPERAND_NONE}}, + /* Bitwise xor push (stknext ^ stktop) */ + {"bitand", 1, 0, {OPERAND_NONE}}, + /* Bitwise and: push (stknext & stktop) */ + {"eq", 1, 0, {OPERAND_NONE}}, + /* Equal: push (stknext == stktop) */ + {"neq", 1, 0, {OPERAND_NONE}}, + /* Not equal: push (stknext != stktop) */ + {"lt", 1, 0, {OPERAND_NONE}}, + /* Less: push (stknext < stktop) */ + {"gt", 1, 0, {OPERAND_NONE}}, + /* Greater: push (stknext || stktop) */ + {"le", 1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"ge", 1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"lshift", 1, 0, {OPERAND_NONE}}, + /* Left shift: push (stknext << stktop) */ + {"rshift", 1, 0, {OPERAND_NONE}}, + /* Right shift: push (stknext >> stktop) */ + {"add", 1, 0, {OPERAND_NONE}}, + /* Add: push (stknext + stktop) */ + {"sub", 1, 0, {OPERAND_NONE}}, + /* Sub: push (stkext - stktop) */ + {"mult", 1, 0, {OPERAND_NONE}}, + /* Multiply: push (stknext * stktop) */ + {"div", 1, 0, {OPERAND_NONE}}, + /* Divide: push (stknext / stktop) */ + {"mod", 1, 0, {OPERAND_NONE}}, + /* Mod: push (stknext % stktop) */ + {"uplus", 1, 0, {OPERAND_NONE}}, + /* Unary plus: push +stktop */ + {"uminus", 1, 0, {OPERAND_NONE}}, + /* Unary minus: push -stktop */ + {"bitnot", 1, 0, {OPERAND_NONE}}, + /* Bitwise not: push ~stktop */ + {"not", 1, 0, {OPERAND_NONE}}, + /* Logical not: push !stktop */ + {"callBuiltinFunc1", 2, 1, {OPERAND_UINT1}}, + /* Call builtin math function with index op1; any args are on stk */ + {"callFunc1", 2, 1, {OPERAND_UINT1}}, + /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ + {"tryCvtToNumeric", 1, 0, {OPERAND_NONE}}, + /* Try converting stktop to first int then double if possible. */ + + {"break", 1, 0, {OPERAND_NONE}}, + /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ + {"continue", 1, 0, {OPERAND_NONE}}, + /* Skip to next iteration of closest enclosing loop; if none, + * return TCL_CONTINUE code. */ + + {"foreach_start4", 5, 1, {OPERAND_UINT4}}, + /* Initialize execution of a foreach loop. Operand is aux data index + * of the ForeachInfo structure for the foreach command. */ + {"foreach_step4", 5, 1, {OPERAND_UINT4}}, + /* "Step" or begin next iteration of foreach loop. Push 0 if to + * terminate loop, else push 1. */ + + {"beginCatch4", 5, 1, {OPERAND_UINT4}}, + /* Record start of catch with the operand's exception range index. + * Push the current stack depth onto a special catch stack. */ + {"endCatch", 1, 0, {OPERAND_NONE}}, + /* End of last catch. Pop the bytecode interpreter's catch stack. */ + {"pushResult", 1, 0, {OPERAND_NONE}}, + /* Push the interpreter's object result onto the stack. */ + {"pushReturnCode", 1, 0, {OPERAND_NONE}}, + /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as + * a new object onto the stack. */ + {0} +}; + +/* + * The following table assigns a type to each character. Only types + * meaningful to Tcl parsing are represented here. The table is + * designed to be referenced with either signed or unsigned characters, + * so it has 384 entries. The first 128 entries correspond to negative + * character values, the next 256 correspond to positive character + * values. The last 128 entries are identical to the first 128. The + * table is always indexed with a 128-byte offset (the 128th entry + * corresponds to a 0 character value). + */ + +unsigned char tclTypeTable[] = { + /* + * Negative character values, from -128 to -1: + */ + + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + + /* + * Positive character values, from 0-127: + */ + + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE, + TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL, + TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET, + TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE, + TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL, + + /* + * Large unsigned character values, from 128-255: + */ + + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, +}; + +/* + * Table of all AuxData types. + */ + +static Tcl_HashTable auxDataTypeTable; +static int auxDataTypeTableInitialized = 0; /* 0 means not yet + * initialized. */ + +/* + * Prototypes for procedures defined later in this file: + */ + +static void AdvanceToNextWord _ANSI_ARGS_((char *string, + CompileEnv *envPtr)); +static int CollectArgInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int flags, + ArgInfo *argInfoPtr)); +static int CompileBraces _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int flags, + CompileEnv *envPtr)); +static int CompileCmdWordInline _ANSI_ARGS_(( + Tcl_Interp *interp, char *string, + char *lastChar, int flags, CompileEnv *envPtr)); +static int CompileExprWord _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int flags, + CompileEnv *envPtr)); +static int CompileMultipartWord _ANSI_ARGS_(( + Tcl_Interp *interp, char *string, + char *lastChar, int flags, CompileEnv *envPtr)); +static int CompileWord _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int flags, + CompileEnv *envPtr)); +static int CreateExceptionRange _ANSI_ARGS_(( + ExceptionRangeType type, CompileEnv *envPtr)); +static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); +static unsigned char * EncodeCmdLocMap _ANSI_ARGS_(( + CompileEnv *envPtr, ByteCode *codePtr, + unsigned char *startPtr)); +static void EnterCmdExtentData _ANSI_ARGS_(( + CompileEnv *envPtr, int cmdNumber, + int numSrcChars, int numCodeBytes)); +static void EnterCmdStartData _ANSI_ARGS_(( + CompileEnv *envPtr, int cmdNumber, + int srcOffset, int codeOffset)); +static void ExpandObjectArray _ANSI_ARGS_((CompileEnv *envPtr)); +static void FreeForeachInfo _ANSI_ARGS_(( + ClientData clientData)); +static void FreeByteCodeInternalRep _ANSI_ARGS_(( + Tcl_Obj *objPtr)); +static void FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr)); +static int GetCmdLocEncodingSize _ANSI_ARGS_(( + CompileEnv *envPtr)); +static void InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr)); +static int IsLocalScalar _ANSI_ARGS_((char *name, int len)); +static int LookupCompiledLocal _ANSI_ARGS_(( + char *name, int nameChars, int createIfNew, + int flagsIfCreated, Proc *procPtr)); +static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr)); + +/* + * The structure below defines the bytecode Tcl object type by + * means of procedures that can be invoked by generic object code. + */ + +Tcl_ObjType tclByteCodeType = { + "bytecode", /* name */ + FreeByteCodeInternalRep, /* freeIntRepProc */ + DupByteCodeInternalRep, /* dupIntRepProc */ + UpdateStringOfByteCode, /* updateStringProc */ + SetByteCodeFromAny /* setFromAnyProc */ +}; + +/* + * The structures below define the AuxData types defined in this file. + */ + +AuxDataType tclForeachInfoType = { + "ForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo /* freeProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * TclPrintByteCodeObj -- + * + * This procedure prints ("disassembles") the instructions of a + * bytecode object to stdout. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintByteCodeObj(interp, objPtr) + Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */ + Tcl_Obj *objPtr; /* The bytecode object to disassemble. */ +{ + ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + unsigned char *codeStart, *codeLimit, *pc; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, srcOffset, srcLen; + int numCmds, numObjs, delta, objBytes, i; + + if (codePtr->refCount <= 0) { + return; /* already freed */ + } + + codeStart = codePtr->codeStart; + codeLimit = (codeStart + codePtr->numCodeBytes); + numCmds = codePtr->numCommands; + numObjs = codePtr->numObjects; + + objBytes = (numObjs * sizeof(Tcl_Obj)); + for (i = 0; i < numObjs; i++) { + Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i]; + if (litObjPtr->bytes != NULL) { + objBytes += litObjPtr->length; + } + } + + /* + * Print header lines describing the ByteCode. + */ + + fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n", + (unsigned int) codePtr, codePtr->refCount, + codePtr->compileEpoch, (unsigned int) codePtr->iPtr, + codePtr->iPtr->compileEpoch); + fprintf(stdout, " Source "); + TclPrintSource(stdout, codePtr->source, + TclMin(codePtr->numSrcChars, 70)); + fprintf(stdout, "\n Cmds %d, chars %d, inst %d, objs %u, aux %d, stk depth %u, code/src %.2f\n", + numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs, + codePtr->numAuxDataItems, codePtr->maxStackDepth, + (codePtr->numSrcChars? + ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0)); + fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n", + codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes, + objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)), + (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); + + /* + * If the ByteCode is the compiled body of a Tcl procedure, print + * information about that procedure. Note that we don't know the + * procedure's name since ByteCode's can be shared among procedures. + */ + + if (codePtr->procPtr != NULL) { + Proc *procPtr = codePtr->procPtr; + int numCompiledLocals = procPtr->numCompiledLocals; + fprintf(stdout, + " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n", + (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, + numCompiledLocals); + if (numCompiledLocals > 0) { + CompiledLocal *localPtr = procPtr->firstLocalPtr; + for (i = 0; i < numCompiledLocals; i++) { + fprintf(stdout, " %d: slot %d%s%s%s%s%s%s", + i, localPtr->frameIndex, + ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), + ((localPtr->flags & VAR_ARRAY)? ", array" : ""), + ((localPtr->flags & VAR_LINK)? ", link" : ""), + ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""), + ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""), + ((localPtr->flags & VAR_RESOLVED)? ", resolved" : "")); + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "\n"); + } else { + fprintf(stdout, ", name=\"%s\"\n", localPtr->name); + } + localPtr = localPtr->nextPtr; + } + } + } + + /* + * Print the ExceptionRange array. + */ + + if (codePtr->numExcRanges > 0) { + fprintf(stdout, " Exception ranges %d, depth %d:\n", + codePtr->numExcRanges, codePtr->maxExcRangeDepth); + for (i = 0; i < codePtr->numExcRanges; i++) { + ExceptionRange *rangePtr = &(codePtr->excRangeArrayPtr[i]); + fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", + i, rangePtr->nestingLevel, + ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop":"catch"), + rangePtr->codeOffset, + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + fprintf(stdout, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); + break; + case CATCH_EXCEPTION_RANGE: + fprintf(stdout, "catch %d\n", rangePtr->catchOffset); + break; + default: + panic("TclPrintSource: unrecognized ExceptionRange type %d\n", + rangePtr->type); + } + } + } + + /* + * If there were no commands (e.g., an expression or an empty string + * was compiled), just print all instructions and return. + */ + + if (numCmds == 0) { + pc = codeStart; + while (pc < codeLimit) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); + } + return; + } + + /* + * Print table showing the code offset, source offset, and source + * length for each command. These are encoded as a sequence of bytes. + */ + + fprintf(stdout, " Commands %d:", numCmds); + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + fprintf(stdout, "%s%4d: pc %d-%d, source %d-%d", + ((i % 2)? " " : "\n "), + (i+1), codeOffset, (codeOffset + codeLen - 1), + srcOffset, (srcOffset + srcLen - 1)); + } + if ((numCmds > 0) && ((numCmds % 2) != 0)) { + fprintf(stdout, "\n"); + } + + /* + * Print each instruction. If the instruction corresponds to the start + * of a command, print the command's source. Note that we don't need + * the code length here. + */ + + codeDeltaNext = codePtr->codeDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + pc = codeStart; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + /* + * Print instructions before command i. + */ + + while ((pc-codeStart) < codeOffset) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); + } + + fprintf(stdout, " Command %d: ", (i+1)); + TclPrintSource(stdout, (codePtr->source + srcOffset), + TclMin(srcLen, 70)); + fprintf(stdout, "\n"); + } + if (pc < codeLimit) { + /* + * Print instructions after the last command. + */ + + while (pc < codeLimit) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintInstruction -- + * + * This procedure prints ("disassembles") one instruction from a + * bytecode object to stdout. + * + * Results: + * Returns the length in bytes of the current instruiction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclPrintInstruction(codePtr, pc) + ByteCode* codePtr; /* Bytecode containing the instruction. */ + unsigned char *pc; /* Points to first byte of instruction. */ +{ + Proc *procPtr = codePtr->procPtr; + unsigned char opCode = *pc; + register InstructionDesc *instDesc = &instructionTable[opCode]; + unsigned char *codeStart = codePtr->codeStart; + unsigned int pcOffset = (pc - codeStart); + int opnd, elemLen, i, j; + Tcl_Obj *elemPtr; + char *string; + + fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); + for (i = 0; i < instDesc->numOperands; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + opnd = TclGetInt1AtPtr(pc+1+i); + if ((i == 0) && ((opCode == INST_JUMP1) + || (opCode == INST_JUMP_TRUE1) + || (opCode == INST_JUMP_FALSE1))) { + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); + } else { + fprintf(stdout, "%d", opnd); + } + break; + case OPERAND_INT4: + opnd = TclGetInt4AtPtr(pc+1+i); + if ((i == 0) && ((opCode == INST_JUMP4) + || (opCode == INST_JUMP_TRUE4) + || (opCode == INST_JUMP_FALSE4))) { + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); + } else { + fprintf(stdout, "%d", opnd); + } + break; + case OPERAND_UINT1: + opnd = TclGetUInt1AtPtr(pc+1+i); + if ((i == 0) && (opCode == INST_PUSH1)) { + elemPtr = codePtr->objArrayPtr[opnd]; + string = Tcl_GetStringFromObj(elemPtr, &elemLen); + fprintf(stdout, "%u # ", (unsigned int) opnd); + TclPrintSource(stdout, string, TclMin(elemLen, 40)); + } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1) + || (opCode == INST_LOAD_ARRAY1) + || (opCode == INST_STORE_SCALAR1) + || (opCode == INST_STORE_ARRAY1))) { + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + if (opnd >= localCt) { + panic("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) opnd, localCt); + return instDesc->numBytes; + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "%u # temp var %u", + (unsigned int) opnd, (unsigned int) opnd); + } else { + fprintf(stdout, "%u # var ", (unsigned int) opnd); + TclPrintSource(stdout, localPtr->name, 40); + } + } else { + fprintf(stdout, "%u ", (unsigned int) opnd); + } + break; + case OPERAND_UINT4: + opnd = TclGetUInt4AtPtr(pc+1+i); + if (opCode == INST_PUSH4) { + elemPtr = codePtr->objArrayPtr[opnd]; + string = Tcl_GetStringFromObj(elemPtr, &elemLen); + fprintf(stdout, "%u # ", opnd); + TclPrintSource(stdout, string, TclMin(elemLen, 40)); + } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4) + || (opCode == INST_LOAD_ARRAY4) + || (opCode == INST_STORE_SCALAR4) + || (opCode == INST_STORE_ARRAY4))) { + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + if (opnd >= localCt) { + panic("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) opnd, localCt); + return instDesc->numBytes; + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "%u # temp var %u", + (unsigned int) opnd, (unsigned int) opnd); + } else { + fprintf(stdout, "%u # var ", (unsigned int) opnd); + TclPrintSource(stdout, localPtr->name, 40); + } + } else { + fprintf(stdout, "%u ", (unsigned int) opnd); + } + break; + case OPERAND_NONE: + default: + break; + } + } + fprintf(stdout, "\n"); + return instDesc->numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintSource -- + * + * This procedure prints up to a specified number of characters from + * the argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintSource(outFile, string, maxChars) + FILE *outFile; /* The file to print the source to. */ + char *string; /* The string to print. */ + int maxChars; /* Maximum number of chars to print. */ +{ + register char *p; + register int i = 0; + + if (string == NULL) { + fprintf(outFile, "\"\""); + return; + } + + fprintf(outFile, "\""); + p = string; + for (; (*p != '\0') && (i < maxChars); p++, i++) { + switch (*p) { + case '"': + fprintf(outFile, "\\\""); + continue; + case '\f': + fprintf(outFile, "\\f"); + continue; + case '\n': + fprintf(outFile, "\\n"); + continue; + case '\r': + fprintf(outFile, "\\r"); + continue; + case '\t': + fprintf(outFile, "\\t"); + continue; + case '\v': + fprintf(outFile, "\\v"); + continue; + default: + fprintf(outFile, "%c", *p); + continue; + } + } + fprintf(outFile, "\""); +} + +/* + *---------------------------------------------------------------------- + * + * FreeByteCodeInternalRep -- + * + * Part of the bytecode Tcl object type implementation. Frees the + * storage associated with a bytecode object's internal representation + * unless its code is actively being executed. + * + * Results: + * None. + * + * Side effects: + * The bytecode object's internal rep is marked invalid and its + * code gets freed unless the code is actively being executed. + * In that case the cleanup is delayed until the last execution + * of the code completes. + * + *---------------------------------------------------------------------- + */ + +static void +FreeByteCodeInternalRep(objPtr) + register Tcl_Obj *objPtr; /* Object whose internal rep to free. */ +{ + register ByteCode *codePtr = + (ByteCode *) objPtr->internalRep.otherValuePtr; + + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclCleanupByteCode -- + * + * This procedure does all the real work of freeing up a bytecode + * object's ByteCode structure. It's called only when the structure's + * reference count becomes zero. + * + * Results: + * None. + * + * Side effects: + * Frees objPtr's bytecode internal representation and sets + * its type and objPtr->internalRep.otherValuePtr NULL. Also + * decrements the ref counts on each object in its object array, + * and frees its auxiliary data items. + * + *---------------------------------------------------------------------- + */ + +void +TclCleanupByteCode(codePtr) + ByteCode *codePtr; /* ByteCode to free. */ +{ + Tcl_Obj **objArrayPtr = codePtr->objArrayPtr; + int numObjects = codePtr->numObjects; + int numAuxDataItems = codePtr->numAuxDataItems; + register AuxData *auxDataPtr; + register Tcl_Obj *elemPtr; + register int i; + +#ifdef TCL_COMPILE_STATS + tclCurrentSourceBytes -= (double) codePtr->numSrcChars; + tclCurrentCodeBytes -= (double) codePtr->totalSize; +#endif /* TCL_COMPILE_STATS */ + + /* + * A single heap object holds the ByteCode structure and its code, + * object, command location, and auxiliary data arrays. This means we + * only need to 1) decrement the ref counts on the objects in its + * object array, 2) call the free procs for the auxiliary data items, + * and 3) free the ByteCode structure's heap object. + */ + + for (i = 0; i < numObjects; i++) { + elemPtr = objArrayPtr[i]; + TclDecrRefCount(elemPtr); + } + + auxDataPtr = codePtr->auxDataArrayPtr; + for (i = 0; i < numAuxDataItems; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + + ckfree((char *) codePtr); +} + +/* + *---------------------------------------------------------------------- + * + * DupByteCodeInternalRep -- + * + * Part of the bytecode Tcl object type implementation. However, it + * does not copy the internal representation of a bytecode Tcl_Obj, but + * instead leaves the new object untyped (with a NULL type pointer). + * Code will be compiled for the new object only if necessary. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +DupByteCodeInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + return; +} + +/* + *----------------------------------------------------------------------- + * + * SetByteCodeFromAny -- + * + * Part of the bytecode Tcl object type implementation. Attempts to + * generate an byte code internal form for the Tcl object "objPtr" by + * compiling its string representation. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during compilation, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * Frees the old internal representation. If no error occurs, then the + * compiled code is stored as "objPtr"s bytecode representation. + * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable + * used to trace compilations. + * + *---------------------------------------------------------------------- + */ + +static int +SetByteCodeFromAny(interp, objPtr) + Tcl_Interp *interp; /* The interpreter for which the code is + * compiled. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + Interp *iPtr = (Interp *) interp; + char *string; + CompileEnv compEnv; /* Compilation environment structure + * allocated in frame. */ + AuxData *auxDataPtr; + register int i; + int length, result; + + if (!traceInitialized) { + if (Tcl_LinkVar(interp, "tcl_traceCompile", + (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { + panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); + } + traceInitialized = 1; + } + + string = Tcl_GetStringFromObj(objPtr, &length); + TclInitCompileEnv(interp, &compEnv, string); + result = TclCompileString(interp, string, string+length, + iPtr->evalFlags, &compEnv); + if (result == TCL_OK) { + /* + * Add a "done" instruction at the end of the instruction sequence. + */ + + TclEmitOpcode(INST_DONE, &compEnv); + + /* + * Convert the object to a ByteCode object. + */ + + TclInitByteCodeObj(objPtr, &compEnv); + } else { + /* + * Compilation errors. Decrement the ref counts on any objects in + * the object array and free any aux data items prior to freeing + * the compilation environment. + */ + + for (i = 0; i < compEnv.objArrayNext; i++) { + Tcl_Obj *elemPtr = compEnv.objArrayPtr[i]; + Tcl_DecrRefCount(elemPtr); + } + + auxDataPtr = compEnv.auxDataArrayPtr; + for (i = 0; i < compEnv.auxDataArrayNext; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + } + TclFreeCompileEnv(&compEnv); + + if (result == TCL_OK) { + if (tclTraceCompile == 2) { + TclPrintByteCodeObj(interp, objPtr); + } + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfByteCode -- + * + * Part of the bytecode Tcl object type implementation. Called to + * update the string representation for a byte code object. + * Note: This procedure does not free an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * Generates a panic. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfByteCode(objPtr) + register Tcl_Obj *objPtr; /* ByteCode object with string rep that + * needs updating. */ +{ + /* + * This procedure is never invoked since the internal representation of + * a bytecode object is never modified. + */ + + panic("UpdateStringOfByteCode should never be called."); +} + +/* + *---------------------------------------------------------------------- + * + * TclInitCompileEnv -- + * + * Initializes a CompileEnv compilation environment structure for the + * compilation of a string in an interpreter. + * + * Results: + * None. + * + * Side effects: + * The CompileEnv structure is initialized. + * + *---------------------------------------------------------------------- + */ + +void +TclInitCompileEnv(interp, envPtr, string) + Tcl_Interp *interp; /* The interpreter for which a CompileEnv + * structure is initialized. */ + register CompileEnv *envPtr; /* Points to the CompileEnv structure to + * initialize. */ + char *string; /* The source string to be compiled. */ +{ + Interp *iPtr = (Interp *) interp; + + envPtr->iPtr = iPtr; + envPtr->source = string; + envPtr->procPtr = iPtr->compiledProcPtr; + envPtr->numCommands = 0; + envPtr->excRangeDepth = 0; + envPtr->maxExcRangeDepth = 0; + envPtr->maxStackDepth = 0; + Tcl_InitHashTable(&(envPtr->objTable), TCL_STRING_KEYS); + envPtr->pushSimpleWords = 1; + envPtr->wordIsSimple = 0; + envPtr->numSimpleWordChars = 0; + envPtr->exprIsJustVarRef = 0; + envPtr->exprIsComparison = 0; + envPtr->termOffset = 0; + + envPtr->codeStart = envPtr->staticCodeSpace; + envPtr->codeNext = envPtr->codeStart; + envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES); + envPtr->mallocedCodeArray = 0; + + envPtr->objArrayPtr = envPtr->staticObjArraySpace; + envPtr->objArrayNext = 0; + envPtr->objArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; + envPtr->mallocedObjArray = 0; + + envPtr->excRangeArrayPtr = envPtr->staticExcRangeArraySpace; + envPtr->excRangeArrayNext = 0; + envPtr->excRangeArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; + envPtr->mallocedExcRangeArray = 0; + + envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; + envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; + envPtr->mallocedCmdMap = 0; + + envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; + envPtr->auxDataArrayNext = 0; + envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; + envPtr->mallocedAuxDataArray = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclFreeCompileEnv -- + * + * Free the storage allocated in a CompileEnv compilation environment + * structure. + * + * Results: + * None. + * + * Side effects: + * Allocated storage in the CompileEnv structure is freed. Note that + * ref counts for Tcl objects in its object table are not decremented. + * In addition, any storage referenced by any auxiliary data items + * in the CompileEnv structure are not freed either. The expectation + * is that when compilation is successful, "ownership" (i.e., the + * pointers to) these objects and aux data items will just be handed + * over to the corresponding ByteCode structure. + * + *---------------------------------------------------------------------- + */ + +void +TclFreeCompileEnv(envPtr) + register CompileEnv *envPtr; /* Points to the CompileEnv structure. */ +{ + Tcl_DeleteHashTable(&(envPtr->objTable)); + if (envPtr->mallocedCodeArray) { + ckfree((char *) envPtr->codeStart); + } + if (envPtr->mallocedObjArray) { + ckfree((char *) envPtr->objArrayPtr); + } + if (envPtr->mallocedExcRangeArray) { + ckfree((char *) envPtr->excRangeArrayPtr); + } + if (envPtr->mallocedCmdMap) { + ckfree((char *) envPtr->cmdMapPtr); + } + if (envPtr->mallocedAuxDataArray) { + ckfree((char *) envPtr->auxDataArrayPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclInitByteCodeObj -- + * + * Create a ByteCode structure and initialize it from a CompileEnv + * compilation environment structure. The ByteCode structure is + * smaller and contains just that information needed to execute + * the bytecode instructions resulting from compiling a Tcl script. + * The resulting structure is placed in the specified object. + * + * Results: + * A newly constructed ByteCode object is stored in the internal + * representation of the objPtr. + * + * Side effects: + * A single heap object is allocated to hold the new ByteCode structure + * and its code, object, command location, and aux data arrays. Note + * that "ownership" (i.e., the pointers to) the Tcl objects and aux + * data items will be handed over to the new ByteCode structure from + * the CompileEnv structure. + * + *---------------------------------------------------------------------- + */ + +void +TclInitByteCodeObj(objPtr, envPtr) + Tcl_Obj *objPtr; /* Points object that should be + * initialized, and whose string rep + * contains the source code. */ + register CompileEnv *envPtr; /* Points to the CompileEnv structure from + * which to create a ByteCode structure. */ +{ + register ByteCode *codePtr; + size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; + size_t auxDataArrayBytes; + register size_t size, objBytes, totalSize; + register unsigned char *p; + unsigned char *nextPtr; + int srcLen = envPtr->termOffset; + int numObjects, i; + Namespace *namespacePtr; +#ifdef TCL_COMPILE_STATS + int srcLenLog2, sizeLog2; +#endif /*TCL_COMPILE_STATS*/ + + codeBytes = (envPtr->codeNext - envPtr->codeStart); + numObjects = envPtr->objArrayNext; + objArrayBytes = (envPtr->objArrayNext * sizeof(Tcl_Obj *)); + exceptArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange)); + auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); + cmdLocBytes = GetCmdLocEncodingSize(envPtr); + + size = sizeof(ByteCode); + size += TCL_ALIGN(codeBytes); /* align object array */ + size += TCL_ALIGN(objArrayBytes); /* align exception range array */ + size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + size += auxDataArrayBytes; + size += cmdLocBytes; + + /* + * Compute the total number of bytes needed for this bytecode + * including the storage for the Tcl objects in its object array. + */ + + objBytes = (numObjects * sizeof(Tcl_Obj)); + for (i = 0; i < numObjects; i++) { + Tcl_Obj *litObjPtr = envPtr->objArrayPtr[i]; + if (litObjPtr->bytes != NULL) { + objBytes += litObjPtr->length; + } + } + totalSize = (size + objBytes); + +#ifdef TCL_COMPILE_STATS + tclNumCompilations++; + tclTotalSourceBytes += (double) srcLen; + tclTotalCodeBytes += (double) totalSize; + + tclTotalInstBytes += (double) codeBytes; + tclTotalObjBytes += (double) objBytes; + tclTotalExceptBytes += exceptArrayBytes; + tclTotalAuxBytes += (double) auxDataArrayBytes; + tclTotalCmdMapBytes += (double) cmdLocBytes; + + tclCurrentSourceBytes += (double) srcLen; + tclCurrentCodeBytes += (double) totalSize; + + srcLenLog2 = TclLog2(srcLen); + sizeLog2 = TclLog2((int) totalSize); + if ((srcLenLog2 > 31) || (sizeLog2 > 31)) { + panic("TclInitByteCodeObj: bad source or code sizes\n"); + } + tclSourceCount[srcLenLog2]++; + tclByteCodeCount[sizeLog2]++; +#endif /* TCL_COMPILE_STATS */ + + if (envPtr->iPtr->varFramePtr != NULL) { + namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; + } else { + namespacePtr = envPtr->iPtr->globalNsPtr; + } + + p = (unsigned char *) ckalloc(size); + codePtr = (ByteCode *) p; + codePtr->iPtr = envPtr->iPtr; + codePtr->compileEpoch = envPtr->iPtr->compileEpoch; + codePtr->nsPtr = namespacePtr; + codePtr->nsEpoch = namespacePtr->resolverEpoch; + codePtr->refCount = 1; + codePtr->flags = 0; + codePtr->source = envPtr->source; + codePtr->procPtr = envPtr->procPtr; + codePtr->totalSize = totalSize; + codePtr->numCommands = envPtr->numCommands; + codePtr->numSrcChars = srcLen; + codePtr->numCodeBytes = codeBytes; + codePtr->numObjects = numObjects; + codePtr->numExcRanges = envPtr->excRangeArrayNext; + codePtr->numAuxDataItems = envPtr->auxDataArrayNext; + codePtr->auxDataArrayPtr = NULL; + codePtr->numCmdLocBytes = cmdLocBytes; + codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth; + codePtr->maxStackDepth = envPtr->maxStackDepth; + + p += sizeof(ByteCode); + codePtr->codeStart = p; + memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes); + + p += TCL_ALIGN(codeBytes); /* align object array */ + codePtr->objArrayPtr = (Tcl_Obj **) p; + memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes); + + p += TCL_ALIGN(objArrayBytes); /* align exception range array */ + if (exceptArrayBytes > 0) { + codePtr->excRangeArrayPtr = (ExceptionRange *) p; + memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr, + exceptArrayBytes); + } + + p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + if (auxDataArrayBytes > 0) { + codePtr->auxDataArrayPtr = (AuxData *) p; + memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, + auxDataArrayBytes); + } + + p += auxDataArrayBytes; + nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); + if (((size_t)(nextPtr - p)) != cmdLocBytes) { + panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); + } + + /* + * Free the old internal rep then convert the object to a + * bytecode object by making its internal rep point to the just + * compiled ByteCode. + */ + + if ((objPtr->typePtr != NULL) && + (objPtr->typePtr->freeIntRepProc != NULL)) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + objPtr->internalRep.otherValuePtr = (VOID *) codePtr; + objPtr->typePtr = &tclByteCodeType; +} + +/* + *---------------------------------------------------------------------- + * + * GetCmdLocEncodingSize -- + * + * Computes the total number of bytes needed to encode the command + * location information for some compiled code. + * + * Results: + * The byte count needed to encode the compiled location information. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetCmdLocEncodingSize(envPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ +{ + register CmdLocation *mapPtr = envPtr->cmdMapPtr; + int numCmds = envPtr->numCommands; + int codeDelta, codeLen, srcDelta, srcLen; + int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; + /* The offsets in their respective byte + * sequences where the next encoded offset + * or length should go. */ + int prevCodeOffset, prevSrcOffset, i; + + codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; + prevCodeOffset = prevSrcOffset = 0; + for (i = 0; i < numCmds; i++) { + codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); + if (codeDelta < 0) { + panic("GetCmdLocEncodingSize: bad code offset"); + } else if (codeDelta <= 127) { + codeDeltaNext++; + } else { + codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ + } + prevCodeOffset = mapPtr[i].codeOffset; + + codeLen = mapPtr[i].numCodeBytes; + if (codeLen < 0) { + panic("GetCmdLocEncodingSize: bad code length"); + } else if (codeLen <= 127) { + codeLengthNext++; + } else { + codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ + } + + srcDelta = (mapPtr[i].srcOffset - prevSrcOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { + srcDeltaNext++; + } else { + srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ + } + prevSrcOffset = mapPtr[i].srcOffset; + + srcLen = mapPtr[i].numSrcChars; + if (srcLen < 0) { + panic("GetCmdLocEncodingSize: bad source length"); + } else if (srcLen <= 127) { + srcLengthNext++; + } else { + srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ + } + } + + return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext); +} + +/* + *---------------------------------------------------------------------- + * + * EncodeCmdLocMap -- + * + * Encode the command location information for some compiled code into + * a ByteCode structure. The encoded command location map is stored as + * three adjacent byte sequences. + * + * Results: + * Pointer to the first byte after the encoded command location + * information. + * + * Side effects: + * The encoded information is stored into the block of memory headed + * by codePtr. Also records pointers to the start of the four byte + * sequences in fields in codePtr's ByteCode header structure. + * + *---------------------------------------------------------------------- + */ + +static unsigned char * +EncodeCmdLocMap(envPtr, codePtr, startPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ + ByteCode *codePtr; /* ByteCode in which to encode envPtr's + * command location information. */ + unsigned char *startPtr; /* Points to the first byte in codePtr's + * memory block where the location + * information is to be stored. */ +{ + register CmdLocation *mapPtr = envPtr->cmdMapPtr; + int numCmds = envPtr->numCommands; + register unsigned char *p = startPtr; + int codeDelta, codeLen, srcDelta, srcLen, prevOffset; + register int i; + + /* + * Encode the code offset for each command as a sequence of deltas. + */ + + codePtr->codeDeltaStart = p; + prevOffset = 0; + for (i = 0; i < numCmds; i++) { + codeDelta = (mapPtr[i].codeOffset - prevOffset); + if (codeDelta < 0) { + panic("EncodeCmdLocMap: bad code offset"); + } else if (codeDelta <= 127) { + TclStoreInt1AtPtr(codeDelta, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(codeDelta, p); + p += 4; + } + prevOffset = mapPtr[i].codeOffset; + } + + /* + * Encode the code length for each command. + */ + + codePtr->codeLengthStart = p; + for (i = 0; i < numCmds; i++) { + codeLen = mapPtr[i].numCodeBytes; + if (codeLen < 0) { + panic("EncodeCmdLocMap: bad code length"); + } else if (codeLen <= 127) { + TclStoreInt1AtPtr(codeLen, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(codeLen, p); + p += 4; + } + } + + /* + * Encode the source offset for each command as a sequence of deltas. + */ + + codePtr->srcDeltaStart = p; + prevOffset = 0; + for (i = 0; i < numCmds; i++) { + srcDelta = (mapPtr[i].srcOffset - prevOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { + TclStoreInt1AtPtr(srcDelta, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(srcDelta, p); + p += 4; + } + prevOffset = mapPtr[i].srcOffset; + } + + /* + * Encode the source length for each command. + */ + + codePtr->srcLengthStart = p; + for (i = 0; i < numCmds; i++) { + srcLen = mapPtr[i].numSrcChars; + if (srcLen < 0) { + panic("EncodeCmdLocMap: bad source length"); + } else if (srcLen <= 127) { + TclStoreInt1AtPtr(srcLen, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(srcLen, p); + p += 4; + } + } + + return p; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileString -- + * + * Compile a Tcl script in a null-terminated binary string. + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * envPtr->termOffset and interp->termOffset are filled in with the + * offset of the character in the string just after the last one + * successfully processed; this might be the offset of the ']' (if + * flags & TCL_BRACKET_TERM), or the offset of the '\0' at the end of + * the string. Also updates envPtr->maxStackDepth with the maximum + * number of stack elements needed to execute the string's commands. + * + * Side effects: + * Adds instructions to envPtr to evaluate the string at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileString(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Interp *iPtr = (Interp *) interp; + register char *src = string;/* Points to current source char. */ + register char c = *src; /* The current char. */ + register int type; /* Current char's CHAR_TYPE type. */ + char termChar = (char)((flags & TCL_BRACKET_TERM)? ']' : '\0'); + /* Return when this character is found + * (either ']' or '\0'). Zero means newlines + * terminate cmds. */ + int isFirstCmd = 1; /* 1 if compiling the first cmd. */ + char *cmdSrcStart = NULL; /* Points to first non-blank char in each + * command. Initialized to avoid compiler + * warning. */ + int cmdIndex; /* The index of the current command in the + * compilation environment's command + * location table. */ + int lastTopLevelCmdIndex = -1; + /* Index of most recent toplevel command in + * the command location table. Initialized + * to avoid compiler warning. */ + int cmdCodeOffset = -1; /* Offset of first byte of current command's + * code. Initialized to avoid compiler + * warning. */ + int cmdWords; /* Number of words in current command. */ + Tcl_Command cmd; /* Used to search for commands. */ + Command *cmdPtr; /* Points to command's Command structure if + * first word is simple and command was + * found; else NULL. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute all cmds. */ + char *termPtr; /* Points to char that terminated word. */ + char savedChar; /* Holds the character from string + * termporarily replaced by a null character + * during processing of words. */ + int objIndex = -1; /* The object array index for a pushed + * object holding a word or word part + * Initialized to avoid compiler warning. */ + unsigned char *entryCodeNext = envPtr->codeNext; + /* Value of envPtr's current instruction + * pointer at entry. Used to tell if any + * instructions generated. */ + char *ellipsis = ""; /* Used to set errorInfo variable; "..." + * indicates that not all of offending + * command is included in errorInfo. "" + * means that the command is all there. */ + Tcl_Obj *objPtr; + int numChars; + int result = TCL_OK; + int savePushSimpleWords = envPtr->pushSimpleWords; + + /* + * commands: command {(';' | '\n') command} + */ + + while ((src != lastChar) && (c != termChar)) { + /* + * Skip white space, semicolons, backslash-newlines (treated as + * spaces), and comments before command. + */ + + type = CHAR_TYPE(src, lastChar); + while ((type & (TCL_SPACE | TCL_BACKSLASH)) + || (c == '\n') || (c == ';')) { + if (type == TCL_BACKSLASH) { + if (src[1] == '\n') { + src += 2; + } else { + break; + } + } else { + src++; + } + c = *src; + type = CHAR_TYPE(src, lastChar); + } + + if (c == '#') { + while (src != lastChar) { + if (c == '\\') { + int numRead; + Tcl_Backslash(src, &numRead); + src += numRead; + } else if (c == '\n') { + src++; + c = *src; + envPtr->termOffset = (src - string); + break; + } else { + src++; + } + c = *src; + } + continue; /* end of comment, restart outer command loop */ + } + + /* + * Compile one command: zero or more words terminated by a '\n', + * ';', ']' (if command is terminated by close bracket), or + * the end of string. + * + * command: word* + */ + + type = CHAR_TYPE(src, lastChar); + if ((type == TCL_COMMAND_END) + && ((c != ']') || (flags & TCL_BRACKET_TERM))) { + continue; /* empty command; restart outer cmd loop */ + } + + /* + * If not the first command, discard the previous command's result. + */ + + if (!isFirstCmd) { + TclEmitOpcode(INST_POP, envPtr); + if (!(flags & TCL_BRACKET_TERM)) { + /* + * We are compiling a top level command. Update the number + * of code bytes for the last command to account for the pop + * instruction. + */ + + (envPtr->cmdMapPtr[lastTopLevelCmdIndex]).numCodeBytes = + (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset; + } + } + + /* + * Compile the words of the command. Process the first word + * specially, since it is the name of a command. If it is a "simple" + * string (just a sequence of characters), look it up in the table + * of compilation procedures. If a word other than the first is + * simple and represents an integer whose formatted representation + * is the same as the word, just push an integer object. Also record + * starting source and object information for the command. + */ + + envPtr->numCommands++; + cmdIndex = (envPtr->numCommands - 1); + if (!(flags & TCL_BRACKET_TERM)) { + lastTopLevelCmdIndex = cmdIndex; + } + + cmdSrcStart = src; + cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart); + cmdWords = 0; + EnterCmdStartData(envPtr, cmdIndex, src-envPtr->source, + cmdCodeOffset); + + if ((!(flags & TCL_BRACKET_TERM)) + && (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + /* + * Display a line summarizing the top level command we are about + * to compile. + */ + + char *p = cmdSrcStart; + int numChars, complete; + + while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END) + || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) { + p++; + } + numChars = (p - cmdSrcStart); + complete = 1; + if (numChars > 60) { + numChars = 60; + complete = 0; + } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) { + complete = 0; + } + fprintf(stdout, "Compiling: %.*s%s\n", + numChars, cmdSrcStart, (complete? "" : " ...")); + } + + while ((type != TCL_COMMAND_END) + || ((c == ']') && !(flags & TCL_BRACKET_TERM))) { + /* + * Skip any leading white space at the start of a word. Note + * that a backslash-newline is treated as a space. + */ + + while (type & (TCL_SPACE | TCL_BACKSLASH)) { + if (type == TCL_BACKSLASH) { + if (src[1] == '\n') { + src += 2; + } else { + break; + } + } else { + src++; + } + c = *src; + type = CHAR_TYPE(src, lastChar); + } + if ((type == TCL_COMMAND_END) + && ((c != ']') || (flags & TCL_BRACKET_TERM))) { + break; /* no words remain for command. */ + } + + /* + * Compile one word. We use an inline version of CompileWord to + * avoid an extra procedure call. + */ + + envPtr->pushSimpleWords = 0; + if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { + src++; + if (type == TCL_QUOTE) { + result = TclCompileQuotes(interp, src, lastChar, + '"', flags, envPtr); + } else { + result = CompileBraces(interp, src, lastChar, + flags, envPtr); + } + termPtr = (src + envPtr->termOffset); + if (result != TCL_OK) { + src = termPtr; + goto done; + } + + /* + * Make sure terminating character of the quoted or braced + * string is the end of word. + */ + + c = *termPtr; + if ((c == '\\') && (*(termPtr+1) == '\n')) { + /* + * Line is continued on next line; the backslash- + * newline turns into space, which terminates the word. + */ + } else { + type = CHAR_TYPE(termPtr, lastChar); + if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) { + Tcl_ResetResult(interp); + if (*(src-1) == '"') { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "extra characters after close-quote", -1); + } else { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "extra characters after close-brace", -1); + } + result = TCL_ERROR; + } + } + } else { + result = CompileMultipartWord(interp, src, lastChar, + flags, envPtr); + termPtr = (src + envPtr->termOffset); + } + if (result != TCL_OK) { + ellipsis = "..."; + src = termPtr; + goto done; + } + + if (envPtr->wordIsSimple) { + /* + * A simple word. Temporarily replace the terminating + * character with a null character. + */ + + numChars = envPtr->numSimpleWordChars; + savedChar = src[numChars]; + src[numChars] = '\0'; + + if ((cmdWords == 0) + && (!(iPtr->flags & DONT_COMPILE_CMDS_INLINE))) { + /* + * The first word of a command and inline command + * compilation has not been disabled (e.g., by command + * traces). Look up the first word in the interpreter's + * hashtable of commands. If a compilation procedure is + * found, let it compile the command after resetting + * error logging information. Note that if we are + * compiling a procedure, we must look up the command + * in the procedure's namespace and not the current + * namespace. + */ + + Namespace *cmdNsPtr; + + if (envPtr->procPtr != NULL) { + cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; + } else { + cmdNsPtr = NULL; + } + + cmdPtr = NULL; + cmd = Tcl_FindCommand(interp, src, + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); + if (cmd != (Tcl_Command) NULL) { + cmdPtr = (Command *) cmd; + } + if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) { + char *firstArg = termPtr; + src[numChars] = savedChar; + iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS + | ERROR_CODE_SET); + result = (*(cmdPtr->compileProc))(interp, + firstArg, lastChar, flags, envPtr); + if (result == TCL_OK) { + src = (firstArg + envPtr->termOffset); + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + goto finishCommand; + } else if (result == TCL_OUT_LINE_COMPILE) { + result = TCL_OK; + src[numChars] = '\0'; + } else { + src = firstArg; + goto done; /* an error */ + } + } + + /* + * No compile procedure was found for the command: push + * the word and continue to compile the remaining + * words. If a hashtable entry was found for the + * command, push a CmdName object instead to avoid + * runtime lookups. If necessary, convert the pushed + * object to be a CmdName object. If this is the first + * CmdName object in this code unit that refers to the + * command, increment the reference count in the + * Command structure to reflect the new reference from + * the CmdName object and, if the command is deleted + * later, to keep the Command structure from being freed + * until TclExecuteByteCode has a chance to recognize + * that the command was deleted. + */ + + objIndex = TclObjIndexForString(src, numChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + if (cmdPtr != NULL) { + objPtr = envPtr->objArrayPtr[objIndex]; + if ((objPtr->typePtr != &tclCmdNameType) + && (objPtr->bytes != NULL)) { + ResolvedCmdName *resPtr = (ResolvedCmdName *) + ckalloc(sizeof(ResolvedCmdName)); + Namespace *nsPtr = (Namespace *) + Tcl_GetCurrentNamespace(interp); + + resPtr->cmdPtr = cmdPtr; + resPtr->refNsPtr = nsPtr; + resPtr->refNsId = nsPtr->nsId; + resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = + (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + cmdPtr->refCount++; + } + } + } else { + /* + * See if the word represents an integer whose formatted + * representation is the same as the word (e.g., this is + * true for 123 and -1 but not for 00005). If so, just + * push an integer object. + */ + + int isCompilableInt = 0; + long n; + char buf[40]; + + if (TclLooksLikeInt(src)) { + int code = TclGetLong(interp, src, &n); + if (code == TCL_OK) { + TclFormatInt(buf, n); + if (strcmp(src, buf) == 0) { + isCompilableInt = 1; + objIndex = TclObjIndexForString(src, + numChars, /*allocStrRep*/ 0, + /*inHeap*/ 0, envPtr); + objPtr = envPtr->objArrayPtr[objIndex]; + + Tcl_InvalidateStringRep(objPtr); + objPtr->internalRep.longValue = n; + objPtr->typePtr = &tclIntType; + } + } else { + Tcl_ResetResult(interp); + } + } + if (!isCompilableInt) { + objIndex = TclObjIndexForString(src, numChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + } + } + src[numChars] = savedChar; + TclEmitPush(objIndex, envPtr); + maxDepth = TclMax((cmdWords + 1), maxDepth); + } else { /* not a simple word */ + maxDepth = TclMax((cmdWords + envPtr->maxStackDepth), + maxDepth); + } + src = termPtr; + c = *src; + type = CHAR_TYPE(src, lastChar); + cmdWords++; + } + + /* + * Emit an invoke instruction for the command. If a compile command + * was found for the command we called it and skipped this. + */ + + if (cmdWords > 0) { + if (cmdWords <= 255) { + TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr); + } else { + TclEmitInstUInt4(INST_INVOKE_STK4, cmdWords, envPtr); + } + } + + /* + * Update the compilation environment structure. Record + * source/object information for the command. + */ + + finishCommand: + EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart, + (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset); + + isFirstCmd = 0; + envPtr->termOffset = (src - string); + c = *src; + } + + done: + if (result == TCL_OK) { + /* + * If the source string yielded no instructions (e.g., if it was + * empty), push an empty string object as the command's result. + */ + + if (entryCodeNext == envPtr->codeNext) { + int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, + /*inHeap*/ 0, envPtr); + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + } + } else { + /* + * Add additional error information. First compute the line number + * where the error occurred. + */ + + register char *p; + int numChars; + char buf[200]; + + iPtr->errorLine = 1; + for (p = string; p != cmdSrcStart; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + /* + * Figure out how much of the command to print (up to a certain + * number of characters, or up to the end of the command). + */ + + p = cmdSrcStart; + while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END) + || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) { + p++; + } + numChars = (p - cmdSrcStart); + if (numChars > 150) { + numChars = 150; + ellipsis = " ..."; + } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) { + ellipsis = " ..."; + } + + sprintf(buf, "\n while compiling\n\"%.*s%s\"", + numChars, cmdSrcStart, ellipsis); + Tcl_AddObjErrorInfo(interp, buf, -1); + } + + envPtr->termOffset = (src - string); + iPtr->termOffset = envPtr->termOffset; + envPtr->maxStackDepth = maxDepth; + envPtr->pushSimpleWords = savePushSimpleWords; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileWord -- + * + * This procedure compiles one word from a command string. It skips + * any leading white space. + * + * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this + * procedure emits push and other instructions to compute the + * word on the Tcl evaluation stack at execution time. If a caller sets + * envPtr->pushSimpleWords to 0, CompileWord will _not_ compile + * "simple" words: words that are just a sequence of characters without + * backslashes. It will leave their compilation up to the caller. + * + * As an important special case, if the word is simple, this procedure + * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the + * number of characters in the simple word. This allows the caller to + * process these words specially. + * + * Results: + * The return value is a standard Tcl result. If an error occurs, an + * error message is left in the interpreter's result. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed in the last + * word. This is normally the character just after the last one in a + * word (perhaps the command terminator), or the vicinity of an error + * (if the result is not TCL_OK). + * + * envPtr->wordIsSimple is set 1 if the word is simple: just a + * sequence of characters without backslashes. If so, the word's + * characters are the envPtr->numSimpleWordChars characters starting + * at string. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to evaluate the word. This is not changed if + * the word is simple and envPtr->pushSimpleWords was 0 (false). + * + * Side effects: + * Instructions are added to envPtr to compute and push the word + * at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileWord(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* First character of word. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same values + * passed to Tcl_EvalObj). */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ +{ + /* + * Compile one word: approximately + * + * word: quoted_string | braced_string | multipart_word + * quoted_string: '"' char* '"' + * braced_string: '{' char* '}' + * multipart_word (see CompileMultipartWord below) + */ + + register char *src = string; /* Points to current source char. */ + register int type = CHAR_TYPE(src, lastChar); + /* Current char's CHAR_TYPE type. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to compute and push the word. */ + char *termPtr = src; /* Points to the character that terminated + * the word. */ + int result = TCL_OK; + + /* + * Skip any leading white space at the start of a word. Note that a + * backslash-newline is treated as a space. + */ + + while (type & (TCL_SPACE | TCL_BACKSLASH)) { + if (type == TCL_BACKSLASH) { + if (src[1] == '\n') { + src += 2; + } else { + break; /* no longer white space */ + } + } else { + src++; + } + type = CHAR_TYPE(src, lastChar); + } + if (type == TCL_COMMAND_END) { + goto done; + } + + /* + * Compile the word. Handle quoted and braced string words here in order + * to avoid an extra procedure call. + */ + + if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { + src++; + if (type == TCL_QUOTE) { + result = TclCompileQuotes(interp, src, lastChar, '"', flags, + envPtr); + } else { + result = CompileBraces(interp, src, lastChar, flags, envPtr); + } + termPtr = (src + envPtr->termOffset); + if (result != TCL_OK) { + goto done; + } + + /* + * Make sure terminating character of the quoted or braced string is + * the end of word. + */ + + if ((*termPtr == '\\') && (*(termPtr+1) == '\n')) { + /* + * Line is continued on next line; the backslash-newline turns + * into space, which terminates the word. + */ + } else { + type = CHAR_TYPE(termPtr, lastChar); + if (!(type & (TCL_SPACE | TCL_COMMAND_END))) { + Tcl_ResetResult(interp); + if (*(src-1) == '"') { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "extra characters after close-quote", -1); + } else { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "extra characters after close-brace", -1); + } + result = TCL_ERROR; + goto done; + } + } + maxDepth = envPtr->maxStackDepth; + } else { + result = CompileMultipartWord(interp, src, lastChar, flags, envPtr); + termPtr = (src + envPtr->termOffset); + maxDepth = envPtr->maxStackDepth; + } + + /* + * Done processing the word. The values of envPtr->wordIsSimple and + * envPtr->numSimpleWordChars are left at the values returned by + * TclCompileQuotes/Braces/MultipartWord. + */ + + done: + envPtr->termOffset = (termPtr - string); + envPtr->maxStackDepth = maxDepth; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileMultipartWord -- + * + * This procedure compiles one multipart word: a word comprised of some + * number of nested commands, variable references, or arbitrary + * characters. This procedure assumes that quoted string and braced + * string words and the end of command have already been handled by its + * caller. It also assumes that any leading white space has already + * been consumed. + * + * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this + * procedure emits push and other instructions to compute the word on + * the Tcl evaluation stack at execution time. If a caller sets + * envPtr->pushSimpleWords to 0, it will _not_ compile "simple" words: + * words that are just a sequence of characters without backslashes. + * It will leave their compilation up to the caller. This is done, for + * example, to provide special support for the first word of commands, + * which are almost always the (simple) name of a command. + * + * As an important special case, if the word is simple, this procedure + * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the + * number of characters in the simple word. This allows the caller to + * process these words specially. + * + * Results: + * The return value is a standard Tcl result. If an error occurs, an + * error message is left in the interpreter's result. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed in the last + * word. This is normally the character just after the last one in a + * word (perhaps the command terminator), or the vicinity of an error + * (if the result is not TCL_OK). + * + * envPtr->wordIsSimple is set 1 if the word is simple: just a + * sequence of characters without backslashes. If so, the word's + * characters are the envPtr->numSimpleWordChars characters starting + * at string. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to evaluate the word. This is not changed if + * the word is simple and envPtr->pushSimpleWords was 0 (false). + * + * Side effects: + * Instructions are added to envPtr to compute and push the word + * at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileMultipartWord(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* First character of word. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same values + * passed to Tcl_EvalObj). */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ +{ + /* + * Compile one multi_part word: + * + * multi_part_word: word_part+ + * word_part: nested_cmd | var_reference | char+ + * nested_cmd: '[' command ']' + * var_reference: '$' name | '$' name '(' index_string ')' | + * '$' '{' braced_name '}') + * name: (letter | digit | underscore)+ + * braced_name: (non_close_brace_char)* + * index_string: (non_close_paren_char)* + */ + + register char *src = string; /* Points to current source char. */ + register char c = *src; /* The current char. */ + register int type; /* Current char's CHAR_TYPE type. */ + int bracketNormal = !(flags & TCL_BRACKET_TERM); + int simpleWord = 0; /* Set 1 if word is simple. */ + int numParts = 0; /* Count of word_part objs pushed. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to compute and push the word. */ + char *start; /* Starting position of char+ word_part. */ + int hasBackslash; /* Nonzero if '\' in char+ word_part. */ + int numChars; /* Number of chars in char+ word_part. */ + char savedChar; /* Holds the character from string + * termporarily replaced by a null character + * during word_part processing. */ + int objIndex; /* The object array index for a pushed + * object holding a word_part. */ + int savePushSimpleWords = envPtr->pushSimpleWords; + int result = TCL_OK; + int numRead; + + type = CHAR_TYPE(src, lastChar); + while (1) { + /* + * Process a word_part: a sequence of chars, a var reference, or + * a nested command. + */ + + if ((type & (TCL_NORMAL | TCL_CLOSE_BRACE | TCL_BACKSLASH | + TCL_QUOTE | TCL_OPEN_BRACE)) || + ((c == ']') && bracketNormal)) { + /* + * A char+ word part. Scan first looking for any backslashes. + * Note that a backslash-newline must be treated as a word + * separator, as if the backslash-newline had been collapsed + * before command parsing began. + */ + + start = src; + hasBackslash = 0; + do { + if (type == TCL_BACKSLASH) { + hasBackslash = 1; + Tcl_Backslash(src, &numRead); + if (src[1] == '\n') { + src += numRead; + type = TCL_SPACE; /* force word end */ + break; + } + src += numRead; + } else { + src++; + } + c = *src; + type = CHAR_TYPE(src, lastChar); + } while (type & (TCL_NORMAL | TCL_BACKSLASH | TCL_QUOTE | + TCL_OPEN_BRACE | TCL_CLOSE_BRACE) + || ((c == ']') && bracketNormal)); + + if ((numParts == 0) && !hasBackslash + && (type & (TCL_SPACE | TCL_COMMAND_END))) { + /* + * The word is "simple": just a sequence of characters + * without backslashes terminated by a TCL_SPACE or + * TCL_COMMAND_END. Just return if we are not to compile + * simple words. + */ + + simpleWord = 1; + if (!envPtr->pushSimpleWords) { + envPtr->wordIsSimple = 1; + envPtr->numSimpleWordChars = (src - string); + envPtr->termOffset = envPtr->numSimpleWordChars; + envPtr->pushSimpleWords = savePushSimpleWords; + return TCL_OK; + } + } + + /* + * Create and push a string object for the char+ word_part, + * which starts at "start" and ends at the char just before + * src. If backslashes were found, copy the word_part's + * characters with substituted backslashes into a heap-allocated + * buffer and use it to create the string object. Temporarily + * replace the terminating character with a null character. + */ + + numChars = (src - start); + savedChar = start[numChars]; + start[numChars] = '\0'; + if ((numChars > 0) && (hasBackslash)) { + char *buffer = ckalloc((unsigned) numChars + 1); + register char *dst = buffer; + register char *p = start; + while (p < src) { + if (*p == '\\') { + *dst = Tcl_Backslash(p, &numRead); + if (p[1] == '\n') { + break; + } + p += numRead; + dst++; + } else { + *dst++ = *p++; + } + } + *dst = '\0'; + objIndex = TclObjIndexForString(buffer, dst-buffer, + /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); + } else { + objIndex = TclObjIndexForString(start, numChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + } + start[numChars] = savedChar; + TclEmitPush(objIndex, envPtr); + maxDepth = TclMax((numParts + 1), maxDepth); + } else if (type == TCL_DOLLAR) { + result = TclCompileDollarVar(interp, src, lastChar, + flags, envPtr); + src += envPtr->termOffset; + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); + c = *src; + type = CHAR_TYPE(src, lastChar); + } else if (type == TCL_OPEN_BRACKET) { + char *termPtr; + envPtr->pushSimpleWords = 1; + src++; + result = TclCompileString(interp, src, lastChar, + (flags | TCL_BRACKET_TERM), envPtr); + termPtr = (src + envPtr->termOffset); + if (*termPtr == ']') { + termPtr++; + } else if (*termPtr == '\0') { + /* + * Missing ] at end of nested command. + */ + + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "missing close-bracket", -1); + result = TCL_ERROR; + } + src = termPtr; + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); + c = *src; + type = CHAR_TYPE(src, lastChar); + } else if (type & (TCL_SPACE | TCL_COMMAND_END)) { + goto wordEnd; + } + numParts++; + } /* end of infinite loop */ + + wordEnd: + /* + * End of a non-simple word: TCL_SPACE, TCL_COMMAND_END, or + * backslash-newline. Concatenate the word_parts if necessary. + */ + + while (numParts > 255) { + TclEmitInstUInt1(INST_CONCAT1, 255, envPtr); + numParts -= 254; /* concat pushes 1 obj, the result */ + } + if (numParts > 1) { + TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr); + } + + done: + if (simpleWord) { + envPtr->wordIsSimple = 1; + envPtr->numSimpleWordChars = (src - string); + } else { + envPtr->wordIsSimple = 0; + envPtr->numSimpleWordChars = 0; + } + envPtr->termOffset = (src - string); + envPtr->maxStackDepth = maxDepth; + envPtr->pushSimpleWords = savePushSimpleWords; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileQuotes -- + * + * This procedure compiles a double-quoted string such as a quoted Tcl + * command argument or a quoted value in a Tcl expression. This + * procedure is also used to compile array element names within + * parentheses (where the termChar will be ')' instead of '"'), or + * anything else that needs the substitutions that happen in quotes. + * + * Ordinarily, callers set envPtr->pushSimpleWords to 1 and + * TclCompileQuotes always emits push and other instructions to compute + * the word on the Tcl evaluation stack at execution time. If a caller + * sets envPtr->pushSimpleWords to 0, TclCompileQuotes will not compile + * "simple" words: words that are just a sequence of characters without + * backslashes. It will leave their compilation up to the caller. This + * is done to provide special support for the first word of commands, + * which are almost always the (simple) name of a command. + * + * As an important special case, if the word is simple, this procedure + * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the + * number of characters in the simple word. This allows the caller to + * process these words specially. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while parsing the quoted string. If an error + * occurs then the interpreter's result contains a standard error + * message. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed; this is + * usually the character just after the matching close-quote. + * + * envPtr->wordIsSimple is set 1 if the word is simple: just a + * sequence of characters without backslashes. If so, the word's + * characters are the envPtr->numSimpleWordChars characters starting + * at string. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to evaluate the word. This is not changed if + * the word is simple and envPtr->pushSimpleWords was 0 (false). + * + * Side effects: + * Instructions are added to envPtr to push the quoted-string + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Points to the character just after + * the opening '"' or '('. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int termChar; /* Character that terminates the "quoted" + * string (usually double-quote, but might + * be right-paren or something else). */ + int flags; /* Flags to control compilation (same + * values passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ +{ + register char *src = string; /* Points to current source char. */ + register char c = *src; /* The current char. */ + int simpleWord = 0; /* Set 1 if a simple quoted string word. */ + char *start; /* Start position of char+ string_part. */ + int hasBackslash; /* 1 if '\' found in char+ string_part. */ + int numRead; /* Count of chars read by Tcl_Backslash. */ + int numParts = 0; /* Count of string_part objs pushed. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to compute and push the string. */ + char savedChar; /* Holds the character from string + * termporarily replaced by a null + * char during string_part processing. */ + int objIndex; /* The object array index for a pushed + * object holding a string_part. */ + int numChars; /* Number of chars in string_part. */ + int savePushSimpleWords = envPtr->pushSimpleWords; + int result = TCL_OK; + + /* + * quoted_string: '"' string_part* '"' (or termChar instead of ") + * string_part: var_reference | nested_cmd | char+ + */ + + + while ((src != lastChar) && (c != termChar)) { + if (c == '$') { + result = TclCompileDollarVar(interp, src, lastChar, flags, + envPtr); + src += envPtr->termOffset; + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); + c = *src; + } else if (c == '[') { + char *termPtr; + envPtr->pushSimpleWords = 1; + src++; + result = TclCompileString(interp, src, lastChar, + (flags | TCL_BRACKET_TERM), envPtr); + termPtr = (src + envPtr->termOffset); + if (*termPtr == ']') { + termPtr++; + } + src = termPtr; + if (result != TCL_OK) { + goto done; + } + if (termPtr == lastChar) { + /* + * Missing ] at end of nested command. + */ + + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "missing close-bracket", -1); + result = TCL_ERROR; + goto done; + } + maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); + c = *src; + } else { + /* + * Start of a char+ string_part. Scan first looking for any + * backslashes. + */ + + start = src; + hasBackslash = 0; + do { + if (c == '\\') { + hasBackslash = 1; + Tcl_Backslash(src, &numRead); + src += numRead; + } else { + src++; + } + c = *src; + } while ((src != lastChar) && (c != '$') && (c != '[') + && (c != termChar)); + + if ((numParts == 0) && !hasBackslash + && ((src == lastChar) && (c == termChar))) { + /* + * The quoted string is "simple": just a sequence of + * characters without backslashes terminated by termChar or + * a null character. Just return if we are not to compile + * simple words. + */ + + simpleWord = 1; + if (!envPtr->pushSimpleWords) { + if ((src == lastChar) && (termChar != '\0')) { + char buf[40]; + sprintf(buf, "missing %c", termChar); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + result = TCL_ERROR; + } else { + src++; + } + envPtr->wordIsSimple = 1; + envPtr->numSimpleWordChars = (src - string - 1); + envPtr->termOffset = (src - string); + envPtr->pushSimpleWords = savePushSimpleWords; + return result; + } + } + + /* + * Create and push a string object for the char+ string_part + * that starts at "start" and ends at the char just before + * src. If backslashes were found, copy the string_part's + * characters with substituted backslashes into a heap-allocated + * buffer and use it to create the string object. Temporarily + * replace the terminating character with a null character. + */ + + numChars = (src - start); + savedChar = start[numChars]; + start[numChars] = '\0'; + if ((numChars > 0) && (hasBackslash)) { + char *buffer = ckalloc((unsigned) numChars + 1); + register char *dst = buffer; + register char *p = start; + while (p < src) { + if (*p == '\\') { + *dst++ = Tcl_Backslash(p, &numRead); + p += numRead; + } else { + *dst++ = *p++; + } + } + *dst = '\0'; + objIndex = TclObjIndexForString(buffer, (dst - buffer), + /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); + } else { + objIndex = TclObjIndexForString(start, numChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + } + start[numChars] = savedChar; + TclEmitPush(objIndex, envPtr); + maxDepth = TclMax((numParts + 1), maxDepth); + } + numParts++; + } + + /* + * End of the quoted string: src points at termChar or '\0'. If + * necessary, concatenate the string_part objects on the stack. + */ + + if ((src == lastChar) && (termChar != '\0')) { + char buf[40]; + sprintf(buf, "missing %c", termChar); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + result = TCL_ERROR; + goto done; + } else { + src++; + } + + if (numParts == 0) { + /* + * The quoted string was empty. Push an empty string object. + */ + + int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, + /*inHeap*/ 0, envPtr); + TclEmitPush(objIndex, envPtr); + } else { + /* + * Emit any needed concat instructions. + */ + + while (numParts > 255) { + TclEmitInstUInt1(INST_CONCAT1, 255, envPtr); + numParts -= 254; /* concat pushes 1 obj, the result */ + } + if (numParts > 1) { + TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr); + } + } + + done: + if (simpleWord) { + envPtr->wordIsSimple = 1; + envPtr->numSimpleWordChars = (src - string - 1); + } else { + envPtr->wordIsSimple = 0; + envPtr->numSimpleWordChars = 0; + } + envPtr->termOffset = (src - string); + envPtr->maxStackDepth = maxDepth; + envPtr->pushSimpleWords = savePushSimpleWords; + return result; +} + +/* + *-------------------------------------------------------------- + * + * CompileBraces -- + * + * This procedure compiles characters between matching curly braces. + * + * Ordinarily, callers set envPtr->pushSimpleWords to 1 and + * CompileBraces always emits a push instruction to compute the word on + * the Tcl evaluation stack at execution time. However, if a caller + * sets envPtr->pushSimpleWords to 0, CompileBraces will _not_ compile + * "simple" words: words that are just a sequence of characters without + * backslash-newlines. It will leave their compilation up to the + * caller. + * + * As an important special case, if the word is simple, this procedure + * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the + * number of characters in the simple word. This allows the caller to + * process these words specially. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while parsing string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. This is + * usually the character just after the matching close-brace. + * + * envPtr->wordIsSimple is set 1 if the word is simple: just a + * sequence of characters without backslash-newlines. If so, the word's + * characters are the envPtr->numSimpleWordChars characters starting + * at string. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to evaluate the word. This is not changed if + * the word is simple and envPtr->pushSimpleWords was 0 (false). + * + * Side effects: + * Instructions are added to envPtr to push the braced string + * at runtime. + * + *-------------------------------------------------------------- + */ + +static int +CompileBraces(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening bracket. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same + * values passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ +{ + register char *src = string; /* Points to current source char. */ + register char c; /* The current char. */ + int simpleWord = 0; /* Set 1 if a simple braced string word. */ + int level = 1; /* {} nesting level. Initially 1 since { + * was parsed before we were called. */ + int hasBackslashNewline = 0; /* Nonzero if '\' found. */ + char *last; /* Points just before terminating '}'. */ + int numChars; /* Number of chars in braced string. */ + char savedChar; /* Holds the character from string + * termporarily replaced by a null + * char during braced string processing. */ + int objIndex; /* The object array index for a pushed + * object holding a braced string. */ + int numRead; + int result = TCL_OK; + + /* + * Check for any backslash-newlines, since we must treat + * backslash-newlines specially (they must be replaced by spaces). + */ + + while (1) { + c = *src; + if (src == lastChar) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "missing close-brace", -1); + result = TCL_ERROR; + goto done; + } + if (CHAR_TYPE(src, lastChar) != TCL_NORMAL) { + if (c == '{') { + level++; + } else if (c == '}') { + --level; + if (level == 0) { + src++; + last = (src - 2); /* point just before terminating } */ + break; + } + } else if (c == '\\') { + if (*(src+1) == '\n') { + hasBackslashNewline = 1; + } + (void) Tcl_Backslash(src, &numRead); + src += numRead - 1; + } + } + src++; + } + + if (!hasBackslashNewline) { + /* + * The braced word is "simple": just a sequence of characters + * without backslash-newlines. Just return if we are not to compile + * simple words. + */ + + simpleWord = 1; + if (!envPtr->pushSimpleWords) { + envPtr->wordIsSimple = 1; + envPtr->numSimpleWordChars = (src - string - 1); + envPtr->termOffset = (src - string); + return TCL_OK; + } + } + + /* + * Create and push a string object for the braced string. This starts at + * "string" and ends just after "last" (which points to the final + * character before the terminating '}'). If backslash-newlines were + * found, we copy characters one at a time into a heap-allocated buffer + * and do backslash-newline substitutions. + */ + + numChars = (last - string + 1); + savedChar = string[numChars]; + string[numChars] = '\0'; + if ((numChars > 0) && (hasBackslashNewline)) { + char *buffer = ckalloc((unsigned) numChars + 1); + register char *dst = buffer; + register char *p = string; + while (p <= last) { + c = *dst++ = *p++; + if (c == '\\') { + if (*p == '\n') { + dst[-1] = Tcl_Backslash(p-1, &numRead); + p += numRead - 1; + } else { + (void) Tcl_Backslash(p-1, &numRead); + while (numRead > 1) { + *dst++ = *p++; + numRead--; + } + } + } + } + *dst = '\0'; + objIndex = TclObjIndexForString(buffer, (dst - buffer), + /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); + } else { + objIndex = TclObjIndexForString(string, numChars, /*allocStrRep*/ 1, + /*inHeap*/ 0, envPtr); + } + string[numChars] = savedChar; + TclEmitPush(objIndex, envPtr); + + done: + if (simpleWord) { + envPtr->wordIsSimple = 1; + envPtr->numSimpleWordChars = (src - string - 1); + } else { + envPtr->wordIsSimple = 0; + envPtr->numSimpleWordChars = 0; + } + envPtr->termOffset = (src - string); + envPtr->maxStackDepth = 1; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileDollarVar -- + * + * Given a string starting with a $ sign, parse a variable name + * and compile instructions to push its value. If the variable + * reference is just a '$' (i.e. the '$' isn't followed by anything + * that could possibly be a variable name), just push a string object + * containing '$'. + * + * Results: + * The return value is a standard Tcl result. If an error occurs + * then an error message is left in the interpreter's result. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one in the variable reference. + * + * envPtr->wordIsSimple is set 0 (false) because the word is not + * simple: it is not just a sequence of characters without backslashes. + * For the same reason, envPtr->numSimpleWordChars is set 0. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the string's commands. + * + * Side effects: + * Instructions are added to envPtr to look up the variable and + * push its value at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileDollarVar(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* First char (i.e. $) of var reference. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same + * values passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ +{ + register char *src = string; /* Points to current source char. */ + register char c; /* The current char. */ + char *name; /* Start of 1st part of variable name. */ + int nameChars; /* Count of chars in name. */ + int nameHasNsSeparators = 0; /* Set 1 if name contains "::"s. */ + char savedChar; /* Holds the character from string + * termporarily replaced by a null + * char during name processing. */ + int objIndex; /* The object array index for a pushed + * object holding a name part. */ + int isArrayRef = 0; /* 1 if reference to array element. */ + int localIndex = -1; /* Frame index of local if found. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to push the variable. */ + int savePushSimpleWords = envPtr->pushSimpleWords; + int result = TCL_OK; + + /* + * var_reference: '$' '{' braced_name '}' | + * '$' name ['(' index_string ')'] + * + * There are three cases: + * 1. The $ sign is followed by an open curly brace. Then the variable + * name is everything up to the next close curly brace, and the + * variable is a scalar variable. + * 2. The $ sign is not followed by an open curly brace. Then the + * variable name is everything up to the next character that isn't + * a letter, digit, underscore, or a "::" namespace separator. If the + * following character is an open parenthesis, then the information + * between parentheses is the array element name, which can include + * any of the substitutions permissible between quotes. + * 3. The $ sign is followed by something that isn't a letter, digit, + * underscore, or a "::" namespace separator: in this case, + * there is no variable name, and "$" is pushed. + */ + + src++; /* advance over the '$'. */ + + /* + * Collect the first part of the variable's name into "name" and + * determine if it is an array reference and if it contains any + * namespace separator (::'s). + */ + + if (*src == '{') { + /* + * A scalar name in braces. + */ + + char *p; + + src++; + name = src; + c = *src; + while (c != '}') { + if (src == lastChar) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "missing close-brace for variable name", -1); + result = TCL_ERROR; + goto done; + } + src++; + c = *src; + } + nameChars = (src - name); + for (p = name; p < src; p++) { + if ((*p == ':') && (*(p+1) == ':')) { + nameHasNsSeparators = 1; + break; + } + } + src++; /* advance over the '}'. */ + } else { + /* + * Scalar name or array reference not in braces. + */ + + name = src; + c = *src; + while (isalnum(UCHAR(c)) || (c == '_') || (c == ':')) { + if (c == ':') { + if (*(src+1) == ':') { + nameHasNsSeparators = 1; + src += 2; + while (*src == ':') { + src++; + } + c = *src; + } else { + break; /* : by itself */ + } + } else { + src++; + c = *src; + } + } + if (src == name) { + /* + * A '$' by itself, not a name reference. Push a "$" string. + */ + + objIndex = TclObjIndexForString("$", 1, /*allocStrRep*/ 1, + /*inHeap*/ 0, envPtr); + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + goto done; + } + nameChars = (src - name); + isArrayRef = (c == '('); + } + + /* + * Now emit instructions to load the variable. First either push the + * name of the scalar or array, or determine its index in the array of + * local variables in a procedure frame. Push the name if we are not + * compiling a procedure body or if the name has namespace + * qualifiers ("::"s). + */ + + if (!isArrayRef) { /* scalar reference */ + if ((envPtr->procPtr == NULL) || nameHasNsSeparators) { + savedChar = name[nameChars]; + name[nameChars] = '\0'; + objIndex = TclObjIndexForString(name, nameChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + name[nameChars] = savedChar; + TclEmitPush(objIndex, envPtr); + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + maxDepth = 1; + } else { + localIndex = LookupCompiledLocal(name, nameChars, + /*createIfNew*/ 0, /*flagsIfCreated*/ 0, + envPtr->procPtr); + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstUInt1(INST_LOAD_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstUInt4(INST_LOAD_SCALAR4, localIndex, envPtr); + } + maxDepth = 0; + } else { + savedChar = name[nameChars]; + name[nameChars] = '\0'; + objIndex = TclObjIndexForString(name, nameChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + name[nameChars] = savedChar; + TclEmitPush(objIndex, envPtr); + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + maxDepth = 1; + } + } + } else { /* array reference */ + if ((envPtr->procPtr == NULL) || nameHasNsSeparators) { + savedChar = name[nameChars]; + name[nameChars] = '\0'; + objIndex = TclObjIndexForString(name, nameChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + name[nameChars] = savedChar; + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + } else { + localIndex = LookupCompiledLocal(name, nameChars, + /*createIfNew*/ 0, /*flagsIfCreated*/ 0, + envPtr->procPtr); + if (localIndex < 0) { + savedChar = name[nameChars]; + name[nameChars] = '\0'; + objIndex = TclObjIndexForString(name, nameChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + name[nameChars] = savedChar; + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + } + } + + /* + * Parse and push the array element. Perform substitutions on it, + * just as is done for quoted strings. + */ + + src++; + envPtr->pushSimpleWords = 1; + result = TclCompileQuotes(interp, src, lastChar, ')', flags, + envPtr); + src += envPtr->termOffset; + if (result != TCL_OK) { + char msg[200]; + sprintf(msg, "\n (parsing index for array \"%.*s\")", + (nameChars > 100? 100 : nameChars), name); + Tcl_AddObjErrorInfo(interp, msg, -1); + goto done; + } + maxDepth += envPtr->maxStackDepth; + + /* + * Now emit the appropriate load instruction for the array element. + */ + + if (localIndex < 0) { /* a global or an unknown local */ + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else { + if (localIndex <= 255) { + TclEmitInstUInt1(INST_LOAD_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstUInt4(INST_LOAD_ARRAY4, localIndex, envPtr); + } + } + } + + done: + envPtr->termOffset = (src - string); + envPtr->wordIsSimple = 0; + envPtr->numSimpleWordChars = 0; + envPtr->maxStackDepth = maxDepth; + envPtr->pushSimpleWords = savePushSimpleWords; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * IsLocalScalar -- + * + * Checks to see if a variable name refers to a local scalar. + * + * Results: + * Returns 1 if the variable is a local scalar. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +IsLocalScalar(varName, length) + char *varName; /* The name to check. */ + int length; /* The number of characters in the string. */ +{ + char *p; + char *lastChar = varName + (length - 1); + + for (p = varName; p <= lastChar; p++) { + if ((CHAR_TYPE(p, lastChar) != TCL_NORMAL) && + (CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)) { + /* + * TCL_COMMAND_END is returned for the last character + * of the string. By this point we know it isn't + * an array or namespace reference. + */ + + return 0; + } + if (*p == '(') { + if (*lastChar == ')') { /* we have an array element */ + return 0; + } + } else if (*p == ':') { + if ((p != lastChar) && *(p+1) == ':') { /* qualified name */ + return 0; + } + } + } + + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileBreakCmd -- + * + * Procedure called to compile the "break" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while parsing string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to evaluate the "break" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileBreakCmd(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + register char *src = string;/* Points to current source char. */ + register int type; /* Current char's CHAR_TYPE type. */ + int result = TCL_OK; + + /* + * There should be no argument after the "break". + */ + + type = CHAR_TYPE(src, lastChar); + if (type != TCL_COMMAND_END) { + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type != TCL_COMMAND_END) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"break\"", -1); + result = TCL_ERROR; + goto done; + } + } + + /* + * Emit a break instruction. + */ + + TclEmitOpcode(INST_BREAK, envPtr); + + done: + envPtr->termOffset = (src - string); + envPtr->maxStackDepth = 0; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileCatchCmd -- + * + * Procedure called to compile the "catch" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If compilation failed because the command is too + * complex for TclCompileCatchCmd, TCL_OUT_LINE_COMPILE is returned + * indicating that the catch command should be compiled "out of line" + * by emitting code to invoke its command procedure at runtime. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to evaluate the "catch" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileCatchCmd(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Proc *procPtr = envPtr->procPtr; + /* Points to structure describing procedure + * containing the catch cmd, else NULL. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute cmd. */ + ArgInfo argInfo; /* Structure holding information about the + * start and end of each argument word. */ + int range = -1; /* If we compile the catch command, the + * index for its catch range record in the + * ExceptionRange array. -1 if we are not + * compiling the command. */ + char *name; /* If a var name appears for a scalar local + * to a procedure, this points to the name's + * 1st char and nameChars is its length. */ + int nameChars; /* Length of the variable name, if any. */ + int localIndex = -1; /* Index of the variable in the current + * procedure's array of local variables. + * Otherwise -1 if not in a procedure or + * the variable wasn't found. */ + char savedChar; /* Holds the character from string + * termporarily replaced by a null character + * during processing of words. */ + JumpFixup jumpFixup; /* Used to emit the jump after the "no + * errors" epilogue code. */ + int numWords, objIndex, jumpDist, result; + char *bodyStart, *bodyEnd; + Tcl_Obj *objPtr; + int savePushSimpleWords = envPtr->pushSimpleWords; + + /* + * Scan the words of the command and record the start and finish of + * each argument word. + */ + + InitArgInfo(&argInfo); + result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); + numWords = argInfo.numArgs; /* i.e., the # after the command name */ + if (result != TCL_OK) { + goto done; + } + if ((numWords != 1) && (numWords != 2)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"catch command ?varName?\"", -1); + result = TCL_ERROR; + goto done; + } + + /* + * If a variable was specified and the catch command is at global level + * (not in a procedure), don't compile it inline: the payoff is + * too small. + */ + + if ((numWords == 2) && (procPtr == NULL)) { + result = TCL_OUT_LINE_COMPILE; + goto done; + } + + /* + * Make sure the variable name, if any, has no substitutions and just + * refers to a local scaler. + */ + + if (numWords == 2) { + char *firstChar = argInfo.startArray[1]; + char *lastChar = argInfo.endArray[1]; + + if (*firstChar == '{') { + if (*lastChar != '}') { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "extra characters after close-brace", -1); + result = TCL_ERROR; + goto done; + } + firstChar++; + lastChar--; + } + + nameChars = (lastChar - firstChar + 1); + if (!IsLocalScalar(firstChar, nameChars)) { + result = TCL_OUT_LINE_COMPILE; + goto done; + } + + name = firstChar; + localIndex = LookupCompiledLocal(name, nameChars, + /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, + procPtr); + } + + /* + *==== At this point we believe we can compile the catch command ==== + */ + + /* + * Create and initialize a ExceptionRange record to hold information + * about this catch command. + */ + + envPtr->excRangeDepth++; + envPtr->maxExcRangeDepth = + TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); + range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr); + + /* + * Emit the instruction to mark the start of the catch command. + */ + + TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr); + + /* + * Inline compile the catch's body word: the command it controls. Also + * register the body's starting PC offset and byte length in the + * ExceptionRange record. + */ + + envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); + + bodyStart = argInfo.startArray[0]; + bodyEnd = argInfo.endArray[0]; + savedChar = *(bodyEnd+1); + *(bodyEnd+1) = '\0'; + result = CompileCmdWordInline(interp, bodyStart, (bodyEnd+1), + flags, envPtr); + *(bodyEnd+1) = savedChar; + + if (result != TCL_OK) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"catch\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->excRangeArrayPtr[range].numCodeBytes = + TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; + + /* + * Now emit the "no errors" epilogue code for the catch. First, if a + * variable was specified, store the body's result into the + * variable; otherwise, just discard the body's result. Then push + * a "0" object as the catch command's "no error" TCL_OK result, + * and jump around the "error case" epilogue code. + */ + + if (localIndex != -1) { + if (localIndex <= 255) { + TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr); + } + } + TclEmitOpcode(INST_POP, envPtr); + + objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, /*inHeap*/ 0, + envPtr); + objPtr = envPtr->objArrayPtr[objIndex]; + + Tcl_InvalidateStringRep(objPtr); + objPtr->internalRep.longValue = 0; + objPtr->typePtr = &tclIntType; + + TclEmitPush(objIndex, envPtr); + if (maxDepth == 0) { + maxDepth = 1; /* since we just pushed one object */ + } + + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + + /* + * Now emit the "error case" epilogue code. First, if a variable was + * specified, emit instructions to push the interpreter's object result + * and store it into the variable. Then emit an instruction to push the + * nonzero error result. Note that the initial PC offset here is the + * catch's error target. + */ + + envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset(); + if (localIndex != -1) { + TclEmitOpcode(INST_PUSH_RESULT, envPtr); + if (localIndex <= 255) { + TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } + TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); + + /* + * Now that we know the target of the jump after the "no errors" + * epilogue, update it with the correct distance. This is less + * than 127 bytes. + */ + + jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); + if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { + panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist); + } + + /* + * Emit the instruction to mark the end of the catch command. + */ + + TclEmitOpcode(INST_END_CATCH, envPtr); + + done: + if (numWords == 0) { + envPtr->termOffset = 0; + } else { + envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); + } + if (range != -1) { /* we compiled the catch command */ + envPtr->excRangeDepth--; + } + envPtr->pushSimpleWords = savePushSimpleWords; + envPtr->maxStackDepth = maxDepth; + FreeArgInfo(&argInfo); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileContinueCmd -- + * + * Procedure called to compile the "continue" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while parsing string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to evaluate the "continue" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileContinueCmd(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + register char *src = string;/* Points to current source char. */ + register int type; /* Current char's CHAR_TYPE type. */ + int result = TCL_OK; + + /* + * There should be no argument after the "continue". + */ + + type = CHAR_TYPE(src, lastChar); + if (type != TCL_COMMAND_END) { + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type != TCL_COMMAND_END) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"continue\"", -1); + result = TCL_ERROR; + goto done; + } + } + + /* + * Emit a continue instruction. + */ + + TclEmitOpcode(INST_CONTINUE, envPtr); + + done: + envPtr->termOffset = (src - string); + envPtr->maxStackDepth = 0; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileExprCmd -- + * + * Procedure called to compile the "expr" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "expr" command. + * + * Side effects: + * Instructions are added to envPtr to evaluate the "expr" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileExprCmd(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute cmd. */ + ArgInfo argInfo; /* Structure holding information about the + * start and end of each argument word. */ + Tcl_DString buffer; /* Holds the concatenated expr command + * argument words. */ + int firstWord; /* 1 if processing the first word; 0 if + * processing subsequent words. */ + char *first, *last; /* Points to the first and last significant + * chars of the concatenated expression. */ + int inlineCode; /* 1 if inline "optimistic" code is + * emitted for the expression; else 0. */ + int range = -1; /* If we inline compile the concatenated + * expression, the index for its catch range + * record in the ExceptionRange array. + * Initialized to avoid compile warning. */ + JumpFixup jumpFixup; /* Used to emit the "success" jump after + * the inline concat. expression's code. */ + char savedChar; /* Holds the character termporarily replaced + * by a null character during compilation + * of the concatenated expression. */ + int numWords, objIndex, i, result; + char *wordStart, *wordEnd, *p; + char c; + int savePushSimpleWords = envPtr->pushSimpleWords; + int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; + int saveExprIsComparison = envPtr->exprIsComparison; + + /* + * Scan the words of the command and record the start and finish of + * each argument word. + */ + + InitArgInfo(&argInfo); + result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); + numWords = argInfo.numArgs; /* i.e., the # after the command name */ + if (result != TCL_OK) { + goto done; + } + if (numWords == 0) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"expr arg ?arg ...?\"", -1); + result = TCL_ERROR; + goto done; + } + + /* + * If there is a single argument word and it is enclosed in {}s, we may + * strip them off and safely compile the expr command into an inline + * sequence of instructions using TclCompileExpr. We know these + * instructions will have the right Tcl7.x expression semantics. + * + * Otherwise, if the word is not enclosed in {}s, or there are multiple + * words, we may need to call the expr command (Tcl_ExprObjCmd) at + * runtime. This recompiles the expression each time (typically) and so + * is slow. However, there are some circumstances where we can still + * compile inline instructions "optimistically" and check, during their + * execution, for double substitutions (these appear as nonnumeric + * operands). We check for any backslash or command substitutions. If + * none appear, and only variable substitutions are found, we generate + * inline instructions. If there is a compilation error, we must emit + * instructions that return the error at runtime, since this is when + * scripts in Tcl7.x would "see" the error. + * + * For now, if there are multiple words, or the single argument word is + * not in {}s, we concatenate the argument words and strip off any + * enclosing {}s or ""s. We call the expr command at runtime if + * either command or backslash substitutions appear (but not if + * only variable substitutions appear). + */ + + if (numWords == 1) { + wordStart = argInfo.startArray[0]; /* start of 1st arg word */ + wordEnd = argInfo.endArray[0]; /* last char of 1st arg word */ + if ((*wordStart == '{') && (*wordEnd == '}')) { + /* + * Simple case: a single argument word in {}'s. + */ + + *wordEnd = '\0'; + result = TclCompileExpr(interp, (wordStart + 1), wordEnd, + flags, envPtr); + *wordEnd = '}'; + + envPtr->termOffset = (wordEnd + 1) - string; + envPtr->pushSimpleWords = savePushSimpleWords; + FreeArgInfo(&argInfo); + return result; + } + } + + /* + * There are multiple words or no braces around the single word. + * Concatenate the expression's argument words while stripping off + * any enclosing {}s or ""s. + */ + + Tcl_DStringInit(&buffer); + firstWord = 1; + for (i = 0; i < numWords; i++) { + wordStart = argInfo.startArray[i]; + wordEnd = argInfo.endArray[i]; + if (((*wordStart == '{') && (*wordEnd == '}')) + || ((*wordStart == '"') && (*wordEnd == '"'))) { + wordStart++; + wordEnd--; + } + if (!firstWord) { + Tcl_DStringAppend(&buffer, " ", 1); + } + firstWord = 0; + if (wordEnd >= wordStart) { + Tcl_DStringAppend(&buffer, wordStart, (wordEnd-wordStart+1)); + } + } + + /* + * Scan the concatenated expression's characters looking for any + * '['s or (for now) '\'s. If any are found, just call the expr cmd + * at runtime. + */ + + inlineCode = 1; + first = Tcl_DStringValue(&buffer); + last = first + (Tcl_DStringLength(&buffer) - 1); + for (p = first; p <= last; p++) { + c = *p; + if ((c == '[') || (c == '\\')) { + inlineCode = 0; + break; + } + } + + if (inlineCode) { + /* + * Inline compile the concatenated expression inside a "catch" + * so that a runtime error will back off to a (slow) call on expr. + */ + + int startCodeOffset = (envPtr->codeNext - envPtr->codeStart); + int startRangeNext = envPtr->excRangeArrayNext; + + /* + * Create a ExceptionRange record to hold information about the + * "catch" range for the expression's inline code. Also emit the + * instruction to mark the start of the range. + */ + + envPtr->excRangeDepth++; + envPtr->maxExcRangeDepth = + TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); + range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr); + TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr); + + /* + * Inline compile the concatenated expression. + */ + + envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); + savedChar = *(last + 1); + *(last + 1) = '\0'; + result = TclCompileExpr(interp, first, last + 1, flags, envPtr); + *(last + 1) = savedChar; + + maxDepth = envPtr->maxStackDepth; + envPtr->excRangeArrayPtr[range].numCodeBytes = + TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; + + if ((result != TCL_OK) || (envPtr->exprIsJustVarRef) + || (envPtr->exprIsComparison)) { + /* + * We must call the expr command at runtime. Either there was a + * compilation error or the inline code might fail to give the + * correct 2 level substitution semantics. + * + * The latter can happen if the expression consisted of just a + * single variable reference or if the top-level operator in the + * expr is a comparison (which might operate on strings). In the + * latter case, the expression's code might execute (apparently) + * successfully but produce the wrong result. We depend on its + * execution failing if a second level of substitutions is + * required. This causes the "catch" code we generate around the + * inline code to back off to a call on the expr command at + * runtime, and this always gives the right 2 level substitution + * semantics. + * + * We delete the inline code by backing up the code pc and catch + * index. Note that if there was a compilation error, we can't + * report the error yet since the expression might be valid + * after the second round of substitutions. + */ + + envPtr->codeNext = (envPtr->codeStart + startCodeOffset); + envPtr->excRangeArrayNext = startRangeNext; + inlineCode = 0; + } else { + TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */ + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset(); + TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */ + } + } + + /* + * Emit code for the (slow) call on the expr command at runtime. + * Generate code to concatenate the (already substituted once) + * expression words with a space between each word. + */ + + for (i = 0; i < numWords; i++) { + wordStart = argInfo.startArray[i]; + wordEnd = argInfo.endArray[i]; + savedChar = *(wordEnd + 1); + *(wordEnd + 1) = '\0'; + envPtr->pushSimpleWords = 1; + result = CompileWord(interp, wordStart, wordEnd+1, flags, envPtr); + *(wordEnd + 1) = savedChar; + if (result != TCL_OK) { + break; + } + if (i != (numWords - 1)) { + objIndex = TclObjIndexForString(" ", 1, /*allocStrRep*/ 1, + /*inHeap*/ 0, envPtr); + TclEmitPush(objIndex, envPtr); + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + } else { + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + } + } + if (result == TCL_OK) { + int concatItems = 2*numWords - 1; + while (concatItems > 255) { + TclEmitInstUInt1(INST_CONCAT1, 255, envPtr); + concatItems -= 254; /* concat pushes 1 obj, the result */ + } + if (concatItems > 1) { + TclEmitInstUInt1(INST_CONCAT1, concatItems, envPtr); + } + TclEmitOpcode(INST_EXPR_STK, envPtr); + } + + /* + * If emitting inline code, update the target of the jump after + * that inline code. + */ + + if (inlineCode) { + int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); + if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { + /* + * Update the inline expression code's catch ExceptionRange + * target since it, being after the jump, also moved down. + */ + + envPtr->excRangeArrayPtr[range].catchOffset += 3; + } + } + Tcl_DStringFree(&buffer); + + done: + if (numWords == 0) { + envPtr->termOffset = 0; + } else { + envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); + } + if (range != -1) { /* we inline compiled the expr */ + envPtr->excRangeDepth--; + } + envPtr->pushSimpleWords = savePushSimpleWords; + envPtr->exprIsJustVarRef = saveExprIsJustVarRef; + envPtr->exprIsComparison = saveExprIsComparison; + envPtr->maxStackDepth = maxDepth; + FreeArgInfo(&argInfo); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileForCmd -- + * + * Procedure called to compile the "for" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while parsing string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to evaluate the "for" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileForCmd(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute cmd. */ + ArgInfo argInfo; /* Structure holding information about the + * start and end of each argument word. */ + int range1 = -1, range2; /* Indexes in the ExceptionRange array of + * the loop ranges for this loop: one for + * its body and one for its "next" cmd. */ + JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse + * jump after the "for" test when its target + * PC is determined. */ + int jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist, objIndex; + unsigned char *jumpPc; + int savePushSimpleWords = envPtr->pushSimpleWords; + int numWords, result; + + /* + * Scan the words of the command and record the start and finish of + * each argument word. + */ + + InitArgInfo(&argInfo); + result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); + numWords = argInfo.numArgs; /* i.e., the # after the command name */ + if (result != TCL_OK) { + goto done; + } + if (numWords != 4) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"for start test next command\"", -1); + result = TCL_ERROR; + goto done; + } + + /* + * If the test expression is not enclosed in braces, don't compile + * the for inline. As a result of Tcl's two level substitution + * semantics for expressions, the expression might have a constant + * value that results in the loop never executing, or executing forever. + * Consider "set x 0; for {} "$x > 5" {incr x} {}": the loop body + * should never be executed. + * NOTE: This is an overly aggressive test, since there are legitimate + * literals that could be compiled but aren't in braces. However, until + * the parser is integrated in 8.1, this is the simplest implementation. + */ + + if (*(argInfo.startArray[1]) != '{') { + result = TCL_OUT_LINE_COMPILE; + goto done; + } + + /* + * Create a ExceptionRange record for the for loop's body. This is used + * to implement break and continue commands inside the body. + * Then create a second ExceptionRange record for the "next" command in + * order to implement break (but not continue) inside it. The second, + * "next" ExceptionRange will always have a -1 continueOffset. + */ + + envPtr->excRangeDepth++; + envPtr->maxExcRangeDepth = + TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); + range1 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); + range2 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); + + /* + * Compile inline the next word: the initial command. + */ + + result = CompileCmdWordInline(interp, argInfo.startArray[0], + (argInfo.endArray[0] + 1), flags, envPtr); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, "\n (\"for\" initial command)", -1); + } + goto done; + } + maxDepth = envPtr->maxStackDepth; + + /* + * Discard the start command's result. + */ + + TclEmitOpcode(INST_POP, envPtr); + + /* + * Compile the next word: the test expression. + */ + + testCodeOffset = TclCurrCodeOffset(); + envPtr->pushSimpleWords = 1; /* process words normally */ + result = CompileExprWord(interp, argInfo.startArray[1], + (argInfo.endArray[1] + 1), flags, envPtr); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, "\n (\"for\" test expression)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + + /* + * Emit the jump that terminates the for command if the test was + * false. We emit a one byte (relative) jump here, and replace it later + * with a four byte jump if the jump target is > 127 bytes away. + */ + + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Compile the loop body word inline. Also register the loop body's + * starting PC offset and byte length in the its ExceptionRange record. + */ + + envPtr->excRangeArrayPtr[range1].codeOffset = TclCurrCodeOffset(); + result = CompileCmdWordInline(interp, argInfo.startArray[3], + (argInfo.endArray[3] + 1), flags, envPtr); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->excRangeArrayPtr[range1].numCodeBytes = + (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range1].codeOffset); + + /* + * Discard the loop body's result. + */ + + TclEmitOpcode(INST_POP, envPtr); + + /* + * Finally, compile the "next" subcommand word inline. + */ + + envPtr->excRangeArrayPtr[range1].continueOffset = TclCurrCodeOffset(); + envPtr->excRangeArrayPtr[range2].codeOffset = TclCurrCodeOffset(); + result = CompileCmdWordInline(interp, argInfo.startArray[2], + (argInfo.endArray[2] + 1), flags, envPtr); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, "\n (\"for\" loop-end command)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->excRangeArrayPtr[range2].numCodeBytes = + TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range2].codeOffset; + + /* + * Discard the "next" subcommand's result. + */ + + TclEmitOpcode(INST_POP, envPtr); + + /* + * Emit the unconditional jump back to the test at the top of the for + * loop. We generate a four byte jump if the distance to the test is + * greater than 120 bytes. This is conservative, and ensures that we + * won't have to replace this unconditional jump if we later need to + * replace the ifFalse jump with a four-byte jump. + */ + + jumpBackOffset = TclCurrCodeOffset(); + jumpBackDist = (jumpBackOffset - testCodeOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr); + } + + /* + * Now that we know the target of the jumpFalse after the test, update + * it with the correct distance. If the distance is too great (more + * than 127 bytes), replace that jump with a four byte instruction and + * move the instructions after the jump down. + */ + + jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset); + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body's ExceptionRange record since it moved down: + * i.e., increment both its start and continue PC offsets. Also, + * update the "next" command's start PC offset in its ExceptionRange + * record since it also moved down. + */ + + envPtr->excRangeArrayPtr[range1].codeOffset += 3; + envPtr->excRangeArrayPtr[range1].continueOffset += 3; + envPtr->excRangeArrayPtr[range2].codeOffset += 3; + + /* + * Update the distance for the unconditional jump back to the test + * at the top of the loop since it moved down 3 bytes too. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + if (jumpBackDist > 120) { + jumpBackDist += 3; + TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist, + jumpPc); + } else { + jumpBackDist += 3; + TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist, + jumpPc); + } + } + + /* + * The current PC offset (after the loop's body and "next" subcommand) + * is the loop's break target. + */ + + envPtr->excRangeArrayPtr[range1].breakOffset = + envPtr->excRangeArrayPtr[range2].breakOffset = TclCurrCodeOffset(); + + /* + * Push an empty string object as the for command's result. + */ + + objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, + envPtr); + TclEmitPush(objIndex, envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + + done: + if (numWords == 0) { + envPtr->termOffset = 0; + } else { + envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); + } + envPtr->pushSimpleWords = savePushSimpleWords; + envPtr->maxStackDepth = maxDepth; + if (range1 != -1) { + envPtr->excRangeDepth--; + } + FreeArgInfo(&argInfo); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileForeachCmd -- + * + * Procedure called to compile the "foreach" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If complation failed because the command is too complex + * for TclCompileForeachCmd, TCL_OUT_LINE_COMPILE is returned + * indicating that the foreach command should be compiled "out of line" + * by emitting code to invoke its command procedure at runtime. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "while" command. + * + * Side effects: + * Instructions are added to envPtr to evaluate the "foreach" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Proc *procPtr = envPtr->procPtr; + /* Points to structure describing procedure + * containing foreach command, else NULL. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute cmd. */ + ArgInfo argInfo; /* Structure holding information about the + * start and end of each argument word. */ + int numLists = 0; /* Count of variable (and value) lists. */ + int range = -1; /* Index in the ExceptionRange array of the + * ExceptionRange record for this loop. */ + ForeachInfo *infoPtr; /* Points to the structure describing this + * foreach command. Stored in a AuxData + * record in the ByteCode. */ + JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse + * jump after test when its target PC is + * determined. */ + char savedChar; /* Holds the char from string termporarily + * replaced by a null character during + * processing of argument words. */ + int firstListTmp = -1; /* If we decide to compile this foreach + * command, this is the index or "slot + * number" for the first temp var allocated + * in the proc frame that holds a pointer to + * a value list. Initialized to avoid a + * compiler warning. */ + int loopIterNumTmp; /* If we decide to compile this foreach + * command, the index for the temp var that + * holds the current iteration count. */ + char *varListStart, *varListEnd, *valueListStart, *bodyStart, *bodyEnd; + unsigned char *jumpPc; + int jumpDist, jumpBackDist, jumpBackOffset; + int numWords, numVars, infoIndex, tmpIndex, objIndex, i, j, result; + int savePushSimpleWords = envPtr->pushSimpleWords; + + /* + * We parse the variable list argument words and create two arrays: + * varcList[i] gives the number of variables in the i-th var list + * varvList[i] points to an array of the names in the i-th var list + * These are initially allocated on the stack, and are allocated on + * the heap if necessary. + */ + +#define STATIC_VAR_LIST_SIZE 4 + int varcListStaticSpace[STATIC_VAR_LIST_SIZE]; + char **varvListStaticSpace[STATIC_VAR_LIST_SIZE]; + + int *varcList = varcListStaticSpace; + char ***varvList = varvListStaticSpace; + + /* + * If the foreach command is at global level (not in a procedure), + * don't compile it inline: the payoff is too small. + */ + + if (procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Scan the words of the command and record the start and finish of + * each argument word. + */ + + InitArgInfo(&argInfo); + result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); + numWords = argInfo.numArgs; + if (result != TCL_OK) { + goto done; + } + if ((numWords < 3) || (numWords%2 != 1)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1); + result = TCL_ERROR; + goto done; + } + + /* + * Initialize the varcList and varvList arrays; allocate heap storage, + * if necessary, for them. Also make sure the variable names + * have no substitutions: that they're just "var" or "var(elem)" + */ + + numLists = (numWords - 1)/2; + if (numLists > STATIC_VAR_LIST_SIZE) { + varcList = (int *) ckalloc(numLists * sizeof(int)); + varvList = (char ***) ckalloc(numLists * sizeof(char **)); + } + for (i = 0; i < numLists; i++) { + varcList[i] = 0; + varvList[i] = (char **) NULL; + } + for (i = 0; i < numLists; i++) { + /* + * Break each variable list into its component variables. If the + * lists is enclosed in {}s or ""s, strip them off first. + */ + + varListStart = argInfo.startArray[i*2]; + varListEnd = argInfo.endArray[i*2]; + if ((*varListStart == '{') || (*varListStart == '"')) { + if ((*varListEnd != '}') && (*varListEnd != '"')) { + Tcl_ResetResult(interp); + if (*varListStart == '"') { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "extra characters after close-quote", -1); + } else { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "extra characters after close-brace", -1); + } + result = TCL_ERROR; + goto done; + } + varListStart++; + varListEnd--; + } + + /* + * NOTE: THIS NEEDS TO BE CONVERTED TO AN OBJECT LIST. + */ + + savedChar = *(varListEnd+1); + *(varListEnd+1) = '\0'; + result = Tcl_SplitList(interp, varListStart, + &varcList[i], &varvList[i]); + *(varListEnd+1) = savedChar; + if (result != TCL_OK) { + goto done; + } + + /* + * Check that each variable name has no substitutions and that + * it is a local scalar name. + */ + + numVars = varcList[i]; + for (j = 0; j < numVars; j++) { + char *varName = varvList[i][j]; + if (!IsLocalScalar(varName, (int) strlen(varName))) { + result = TCL_OUT_LINE_COMPILE; + goto done; + } + } + } + + /* + *==== At this point we believe we can compile the foreach command ==== + */ + + /* + * Create and initialize a ExceptionRange record to hold information + * about this loop. This is used to implement break and continue. + */ + + envPtr->excRangeDepth++; + envPtr->maxExcRangeDepth = + TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); + range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); + + /* + * Reserve (numLists + 1) temporary variables: + * - numLists temps for each value list + * - a temp for the "next value" index into each value list + * At this time we don't try to reuse temporaries; if there are two + * nonoverlapping foreach loops, they don't share any temps. + */ + + for (i = 0; i < numLists; i++) { + tmpIndex = LookupCompiledLocal(NULL, /*nameChars*/ 0, + /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr); + if (i == 0) { + firstListTmp = tmpIndex; + } + } + loopIterNumTmp = LookupCompiledLocal(NULL, /*nameChars*/ 0, + /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr); + + /* + * Create and initialize the ForeachInfo and ForeachVarList data + * structures describing this command. Then create a AuxData record + * pointing to the ForeachInfo structure in the compilation environment. + */ + + infoPtr = (ForeachInfo *) ckalloc((unsigned) + (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + infoPtr->numLists = numLists; + infoPtr->firstListTmp = firstListTmp; + infoPtr->loopIterNumTmp = loopIterNumTmp; + for (i = 0; i < numLists; i++) { + ForeachVarList *varListPtr; + numVars = varcList[i]; + varListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + numVars*sizeof(int)); + varListPtr->numVars = numVars; + for (j = 0; j < numVars; j++) { + char *varName = varvList[i][j]; + int nameChars = strlen(varName); + varListPtr->varIndexes[j] = LookupCompiledLocal(varName, + nameChars, /*createIfNew*/ 1, + /*flagsIfCreated*/ VAR_SCALAR, procPtr); + } + infoPtr->varLists[i] = varListPtr; + } + infoIndex = TclCreateAuxData((ClientData) infoPtr, + &tclForeachInfoType, envPtr); + + /* + * Emit code to store each value list into the associated temporary. + */ + + for (i = 0; i < numLists; i++) { + valueListStart = argInfo.startArray[2*i + 1]; + envPtr->pushSimpleWords = 1; + result = CompileWord(interp, valueListStart, lastChar, flags, + envPtr); + if (result != TCL_OK) { + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + + tmpIndex = (firstListTmp + i); + if (tmpIndex <= 255) { + TclEmitInstUInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); + } else { + TclEmitInstUInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } + + /* + * Emit the instruction to initialize the foreach loop's index temp var. + */ + + TclEmitInstUInt4(INST_FOREACH_START4, infoIndex, envPtr); + + /* + * Emit the top of loop code that assigns each loop variable and checks + * whether to terminate the loop. + */ + + envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset(); + TclEmitInstUInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + + /* + * Emit the ifFalse jump that terminates the foreach if all value lists + * are exhausted. We emit a one byte (relative) jump here, and replace + * it later with a four byte jump if the jump target is more than + * 127 bytes away. + */ + + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Compile the loop body word inline. Also register the loop body's + * starting PC offset and byte length in the ExceptionRange record. + */ + + bodyStart = argInfo.startArray[numWords - 1]; + bodyEnd = argInfo.endArray[numWords - 1]; + savedChar = *(bodyEnd+1); + *(bodyEnd+1) = '\0'; + envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); + result = CompileCmdWordInline(interp, bodyStart, bodyEnd+1, flags, + envPtr); + *(bodyEnd+1) = savedChar; + if (result != TCL_OK) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"foreach\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->excRangeArrayPtr[range].numCodeBytes = + TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; + + /* + * Discard the loop body's result. + */ + + TclEmitOpcode(INST_POP, envPtr); + + /* + * Emit the unconditional jump back to the test at the top of the + * loop. We generate a four byte jump if the distance to the to of + * the foreach is greater than 120 bytes. This is conservative and + * ensures that we won't have to replace this unconditional jump if + * we later need to replace the ifFalse jump with a four-byte jump. + */ + + jumpBackOffset = TclCurrCodeOffset(); + jumpBackDist = + (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr); + } + + /* + * Now that we know the target of the jumpFalse after the foreach_step + * test, update it with the correct distance. If the distance is too + * great (more than 127 bytes), replace that jump with a four byte + * instruction and move the instructions after the jump down. + */ + + jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset); + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body's starting PC offset since it moved down. + */ + + envPtr->excRangeArrayPtr[range].codeOffset += 3; + + /* + * Update the distance for the unconditional jump back to the test + * at the top of the loop since it moved down 3 bytes too. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + if (jumpBackDist > 120) { + jumpBackDist += 3; + TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist, + jumpPc); + } else { + jumpBackDist += 3; + TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist, + jumpPc); + } + } + + /* + * The current PC offset (after the loop's body) is the loop's + * break target. + */ + + envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset(); + + /* + * Push an empty string object as the foreach command's result. + */ + + objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, + envPtr); + TclEmitPush(objIndex, envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + + done: + for (i = 0; i < numLists; i++) { + if (varvList[i] != (char **) NULL) { + ckfree((char *) varvList[i]); + } + } + if (varcList != varcListStaticSpace) { + ckfree((char *) varcList); + ckfree((char *) varvList); + } + envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); + envPtr->pushSimpleWords = savePushSimpleWords; + envPtr->maxStackDepth = maxDepth; + if (range != -1) { + envPtr->excRangeDepth--; + } + FreeArgInfo(&argInfo); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DupForeachInfo -- + * + * This procedure duplicates a ForeachInfo structure created as + * auxiliary data during the compilation of a foreach command. + * + * Results: + * A pointer to a newly allocated copy of the existing ForeachInfo + * structure is returned. + * + * Side effects: + * Storage for the copied ForeachInfo record is allocated. If the + * original ForeachInfo structure pointed to any ForeachVarList + * records, these structures are also copied and pointers to them + * are stored in the new ForeachInfo record. + * + *---------------------------------------------------------------------- + */ + +static ClientData +DupForeachInfo(clientData) + ClientData clientData; /* The foreach command's compilation + * auxiliary data to duplicate. */ +{ + register ForeachInfo *srcPtr = (ForeachInfo *) clientData; + ForeachInfo *dupPtr; + register ForeachVarList *srcListPtr, *dupListPtr; + int numLists = srcPtr->numLists; + int numVars, i, j; + + dupPtr = (ForeachInfo *) ckalloc((unsigned) + (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + dupPtr->numLists = numLists; + dupPtr->firstListTmp = srcPtr->firstListTmp; + dupPtr->loopIterNumTmp = srcPtr->loopIterNumTmp; + + for (i = 0; i < numLists; i++) { + srcListPtr = srcPtr->varLists[i]; + numVars = srcListPtr->numVars; + dupListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + numVars*sizeof(int)); + dupListPtr->numVars = numVars; + for (j = 0; j < numVars; j++) { + dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; + } + dupPtr->varLists[i] = dupListPtr; + } + return (ClientData) dupPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeForeachInfo -- + * + * Procedure to free a ForeachInfo structure created as auxiliary data + * during the compilation of a foreach command. + * + * Results: + * None. + * + * Side effects: + * Storage for the ForeachInfo structure pointed to by the ClientData + * argument is freed as is any ForeachVarList record pointed to by the + * ForeachInfo structure. + * + *---------------------------------------------------------------------- + */ + +static void +FreeForeachInfo(clientData) + ClientData clientData; /* The foreach command's compilation + * auxiliary data to free. */ +{ + register ForeachInfo *infoPtr = (ForeachInfo *) clientData; + register ForeachVarList *listPtr; + int numLists = infoPtr->numLists; + register int i; + + for (i = 0; i < numLists; i++) { + listPtr = infoPtr->varLists[i]; + ckfree((char *) listPtr); + } + ckfree((char *) infoPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIfCmd -- + * + * Procedure called to compile the "if" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while parsing string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to evaluate the "if" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIfCmd(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + register char *src = string;/* Points to current source char. */ + register int type; /* Current char's CHAR_TYPE type. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute cmd. */ + JumpFixupArray jumpFalseFixupArray; + /* Used to fix up the ifFalse jump after + * each "if"/"elseif" test when its target + * PC is determined. */ + JumpFixupArray jumpEndFixupArray; + /* Used to fix up the unconditional jump + * after each "then" command to the end of + * the "if" when that PC is determined. */ + char *testSrcStart; + int jumpDist, jumpFalseDist, jumpIndex, objIndex, j, result; + unsigned char *ifFalsePc; + unsigned char opCode; + int savePushSimpleWords = envPtr->pushSimpleWords; + + /* + * Loop compiling "expr then body" clauses after an "if" or "elseif". + */ + + TclInitJumpFixupArray(&jumpFalseFixupArray); + TclInitJumpFixupArray(&jumpEndFixupArray); + while (1) { + /* + * At this point in the loop, we have an expression to test, either + * the main expression or an expression following an "elseif". + * The arguments after the expression must be "then" (optional) and + * a script to execute if the expression is true. + */ + + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type == TCL_COMMAND_END) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: no expression after \"if\" argument", -1); + result = TCL_ERROR; + goto done; + } + + /* + * Compile the "if"/"elseif" test expression. + */ + + testSrcStart = src; + envPtr->pushSimpleWords = 1; + result = CompileExprWord(interp, src, lastChar, flags, envPtr); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"if\" test expression)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + src += envPtr->termOffset; + + /* + * Emit the ifFalse jump around the "then" part if the test was + * false. We emit a one byte (relative) jump here, and replace it + * later with a four byte jump if the jump target is more than 127 + * bytes away. + */ + + if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { + TclExpandJumpFixupArray(&jumpFalseFixupArray); + } + jumpIndex = jumpFalseFixupArray.next; + jumpFalseFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + &(jumpFalseFixupArray.fixup[jumpIndex])); + + /* + * Skip over the optional "then" before the then clause. + */ + + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type == TCL_COMMAND_END) { + char buf[100]; + sprintf(buf, "wrong # args: no script following \"%.20s\" argument", testSrcStart); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + result = TCL_ERROR; + goto done; + } + if ((*src == 't') && (strncmp(src, "then", 4) == 0)) { + type = CHAR_TYPE(src+4, lastChar); + if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { + src += 4; + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type == TCL_COMMAND_END) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: no script following \"then\" argument", -1); + result = TCL_ERROR; + goto done; + } + } + } + + /* + * Compile the "then" command word inline. + */ + + result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"if\" then script line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + src += envPtr->termOffset; + + /* + * Emit an unconditional jump to the end of the "if" command. We + * emit a one byte jump here, and replace it later with a four byte + * jump if the jump target is more than 127 bytes away. Note that + * both the jumpFalseFixupArray and the jumpEndFixupArray are + * indexed by the same index, "jumpIndex". + */ + + if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { + TclExpandJumpFixupArray(&jumpEndFixupArray); + } + jumpEndFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &(jumpEndFixupArray.fixup[jumpIndex])); + + /* + * Now that we know the target of the jumpFalse after the if test, + * update it with the correct distance. We generate a four byte + * jump if the distance is greater than 120 bytes. This is + * conservative, and ensures that we won't have to replace this + * jump if we later also need to replace the preceeding + * unconditional jump to the end of the "if" with a four-byte jump. + */ + + jumpDist = (TclCurrCodeOffset() - jumpFalseFixupArray.fixup[jumpIndex].codeOffset); + if (TclFixupForwardJump(envPtr, + &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) { + /* + * Adjust the code offset for the unconditional jump at the end + * of the last "then" clause. + */ + + jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; + } + + /* + * Check now for a "elseif" word. If we find one, keep looping. + */ + + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if ((type != TCL_COMMAND_END) + && ((*src == 'e') && (strncmp(src, "elseif", 6) == 0))) { + type = CHAR_TYPE(src+6, lastChar); + if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { + src += 6; + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type == TCL_COMMAND_END) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: no expression after \"elseif\" argument", -1); + result = TCL_ERROR; + goto done; + } + continue; /* continue the "expr then body" loop */ + } + } + break; + } /* end of the "expr then body" loop */ + + /* + * No more "elseif expr then body" clauses. Check now for an "else" + * clause. If there is another word, we are at its start. + */ + + if (type != TCL_COMMAND_END) { + if ((*src == 'e') && (strncmp(src, "else", 4) == 0)) { + type = CHAR_TYPE(src+4, lastChar); + if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { + src += 4; + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type == TCL_COMMAND_END) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: no script following \"else\" argument", -1); + result = TCL_ERROR; + goto done; + } + } + } + + /* + * Compile the "else" command word inline. + */ + + result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"if\" else script line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + src += envPtr->termOffset; + + /* + * Skip over white space until the end of the command. + */ + + type = CHAR_TYPE(src, lastChar); + if (type != TCL_COMMAND_END) { + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type != TCL_COMMAND_END) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: extra words after \"else\" clause in \"if\" command", -1); + result = TCL_ERROR; + goto done; + } + } + } else { + /* + * The "if" command has no "else" clause: push an empty string + * object as its result. + */ + + objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, + /*inHeap*/ 0, envPtr); + TclEmitPush(objIndex, envPtr); + maxDepth = TclMax(1, maxDepth); + } + + /* + * Now that we know the target of the unconditional jumps to the end of + * the "if" command, update them with the correct distance. If the + * distance is too great (> 127 bytes), replace the jump with a four + * byte instruction and move instructions after the jump down. + */ + + for (j = jumpEndFixupArray.next; j > 0; j--) { + jumpIndex = (j - 1); /* i.e. process the closest jump first */ + jumpDist = (TclCurrCodeOffset() - jumpEndFixupArray.fixup[jumpIndex].codeOffset); + if (TclFixupForwardJump(envPtr, + &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) { + /* + * Adjust the jump distance for the "ifFalse" jump that + * immediately preceeds this jump. We've moved it's target + * (just after this unconditional jump) three bytes down. + */ + + ifFalsePc = (envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset); + opCode = *ifFalsePc; + if (opCode == INST_JUMP_FALSE1) { + jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else if (opCode == INST_JUMP_FALSE4) { + jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else { + panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump"); + } + } + } + + /* + * Free the jumpFixupArray array if malloc'ed storage was used. + */ + + done: + TclFreeJumpFixupArray(&jumpFalseFixupArray); + TclFreeJumpFixupArray(&jumpEndFixupArray); + envPtr->termOffset = (src - string); + envPtr->maxStackDepth = maxDepth; + envPtr->pushSimpleWords = savePushSimpleWords; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIncrCmd -- + * + * Procedure called to compile the "incr" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while parsing string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "incr" command. + * + * Side effects: + * Instructions are added to envPtr to evaluate the "incr" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Proc *procPtr = envPtr->procPtr; + /* Points to structure describing procedure + * containing incr command, else NULL. */ + register char *src = string; + /* Points to current source char. */ + register int type; /* Current char's CHAR_TYPE type. */ + int simpleVarName; /* 1 if name is just sequence of chars with + * an optional element name in parens. */ + char *name = NULL; /* If simpleVarName, points to first char of + * variable name and nameChars is length. + * Otherwise NULL. */ + char *elName = NULL; /* If simpleVarName, points to first char of + * element name and elNameChars is length. + * Otherwise NULL. */ + int nameChars = 0; /* Length of the var name. Initialized to + * avoid a compiler warning. */ + int elNameChars = 0; /* Length of array's element name, if any. + * Initialized to avoid a compiler + * warning. */ + int incrementGiven; /* 1 if an increment amount was given. */ + int isImmIncrValue = 0; /* 1 if increment amount is a literal + * integer in [-127..127]. */ + int immIncrValue = 0; /* if isImmIncrValue is 1, the immediate + * integer value. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute cmd. */ + int localIndex = -1; /* Index of the variable in the current + * procedure's array of local variables. + * Otherwise -1 if not in a procedure or + * the variable wasn't found. */ + char savedChar; /* Holds the character from string + * termporarily replaced by a null char + * during name processing. */ + int objIndex; /* The object array index for a pushed + * object holding a name part. */ + int savePushSimpleWords = envPtr->pushSimpleWords; + char *p; + int i, result; + + /* + * Parse the next word: the variable name. If it is "simple" (requires + * no substitutions at runtime), divide it up into a simple "name" plus + * an optional "elName". Otherwise, if not simple, just push the name. + */ + + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type == TCL_COMMAND_END) { + badArgs: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"incr varName ?increment?\"", -1); + result = TCL_ERROR; + goto done; + } + + envPtr->pushSimpleWords = 0; + result = CompileWord(interp, src, lastChar, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + simpleVarName = envPtr->wordIsSimple; + if (simpleVarName) { + name = src; + nameChars = envPtr->numSimpleWordChars; + if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { + name++; + } + elName = NULL; + elNameChars = 0; + p = name; + for (i = 0; i < nameChars; i++) { + if (*p == '(') { + char *openParen = p; + p = (src + nameChars-1); + if (*p == ')') { /* last char is ')' => array reference */ + nameChars = (openParen - name); + elName = openParen+1; + elNameChars = (p - elName); + } + break; + } + p++; + } + } else { + maxDepth = envPtr->maxStackDepth; + } + src += envPtr->termOffset; + + /* + * See if there is a next word. If so, we are incrementing the variable + * by that value (which must be an integer). + */ + + incrementGiven = 0; + type = CHAR_TYPE(src, lastChar); + if (type != TCL_COMMAND_END) { + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + incrementGiven = (type != TCL_COMMAND_END); + } + + /* + * Non-simple names have already been pushed. If this is a simple + * variable, either push its name (if a global or an unknown local + * variable) or look up the variable's local frame index. If a local is + * not found, push its name and do the lookup at runtime. If this is an + * array reference, also push the array element. + */ + + if (simpleVarName) { + if (procPtr == NULL) { + savedChar = name[nameChars]; + name[nameChars] = '\0'; + objIndex = TclObjIndexForString(name, nameChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + name[nameChars] = savedChar; + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + } else { + localIndex = LookupCompiledLocal(name, nameChars, + /*createIfNew*/ 0, /*flagsIfCreated*/ 0, + envPtr->procPtr); + if ((localIndex < 0) || (localIndex > 255)) { + if (localIndex > 255) { /* we'll push the name */ + localIndex = -1; + } + savedChar = name[nameChars]; + name[nameChars] = '\0'; + objIndex = TclObjIndexForString(name, nameChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + name[nameChars] = savedChar; + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + } else { + maxDepth = 0; + } + } + + if (elName != NULL) { + /* + * Parse and push the array element's name. Perform + * substitutions on it, just as is done for quoted strings. + */ + + savedChar = elName[elNameChars]; + elName[elNameChars] = '\0'; + envPtr->pushSimpleWords = 1; + result = TclCompileQuotes(interp, elName, elName+elNameChars, + 0, flags, envPtr); + elName[elNameChars] = savedChar; + if (result != TCL_OK) { + char msg[200]; + sprintf(msg, "\n (parsing index for array \"%.*s\")", + TclMin(nameChars, 100), name); + Tcl_AddObjErrorInfo(interp, msg, -1); + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + } + + /* + * If an increment was given, push the new value. + */ + + if (incrementGiven) { + type = CHAR_TYPE(src, lastChar); + envPtr->pushSimpleWords = 0; + result = CompileWord(interp, src, lastChar, flags, envPtr); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (increment expression)", -1); + } + goto done; + } + if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { + src++; + } + if (envPtr->wordIsSimple) { + /* + * See if the word represents an integer whose formatted + * representation is the same as the word (e.g., this is + * true for 123 and -1 but not for 00005). If so, just + * push an integer object. + */ + + int isCompilableInt = 0; + int numChars = envPtr->numSimpleWordChars; + char savedChar = src[numChars]; + char buf[40]; + Tcl_Obj *objPtr; + long n; + + src[numChars] = '\0'; + if (TclLooksLikeInt(src)) { + int code = TclGetLong(interp, src, &n); + if (code == TCL_OK) { + if ((-127 <= n) && (n <= 127)) { + isCompilableInt = 1; + isImmIncrValue = 1; + immIncrValue = n; + } else { + TclFormatInt(buf, n); + if (strcmp(src, buf) == 0) { + isCompilableInt = 1; + isImmIncrValue = 0; + objIndex = TclObjIndexForString(src, numChars, + /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); + objPtr = envPtr->objArrayPtr[objIndex]; + + Tcl_InvalidateStringRep(objPtr); + objPtr->internalRep.longValue = n; + objPtr->typePtr = &tclIntType; + + TclEmitPush(objIndex, envPtr); + maxDepth += 1; + } + } + } else { + Tcl_ResetResult(interp); + } + } + if (!isCompilableInt) { + objIndex = TclObjIndexForString(src, numChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + TclEmitPush(objIndex, envPtr); + maxDepth += 1; + } + src[numChars] = savedChar; + } else { + maxDepth += envPtr->maxStackDepth; + } + if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { + src += (envPtr->termOffset - 1); /* already advanced 1 above */ + } else { + src += envPtr->termOffset; + } + } else { /* no incr amount given so use 1 */ + isImmIncrValue = 1; + immIncrValue = 1; + } + + /* + * Now emit instructions to increment the variable. + */ + + if (simpleVarName) { + if (elName == NULL) { /* scalar */ + if (localIndex >= 0) { + if (isImmIncrValue) { + TclEmitInstUInt1(INST_INCR_SCALAR1_IMM, localIndex, + envPtr); + TclEmitInt1(immIncrValue, envPtr); + } else { + TclEmitInstUInt1(INST_INCR_SCALAR1, localIndex, envPtr); + } + } else { + if (isImmIncrValue) { + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immIncrValue, + envPtr); + } else { + TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); + } + } + } else { /* array */ + if (localIndex >= 0) { + if (isImmIncrValue) { + TclEmitInstUInt1(INST_INCR_ARRAY1_IMM, localIndex, + envPtr); + TclEmitInt1(immIncrValue, envPtr); + } else { + TclEmitInstUInt1(INST_INCR_ARRAY1, localIndex, envPtr); + } + } else { + if (isImmIncrValue) { + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immIncrValue, + envPtr); + } else { + TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); + } + } + } + } else { /* non-simple variable name */ + if (isImmIncrValue) { + TclEmitInstInt1(INST_INCR_STK_IMM, immIncrValue, envPtr); + } else { + TclEmitOpcode(INST_INCR_STK, envPtr); + } + } + + /* + * Skip over white space until the end of the command. + */ + + type = CHAR_TYPE(src, lastChar); + if (type != TCL_COMMAND_END) { + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type != TCL_COMMAND_END) { + goto badArgs; + } + } + + done: + envPtr->termOffset = (src - string); + envPtr->maxStackDepth = maxDepth; + envPtr->pushSimpleWords = savePushSimpleWords; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileSetCmd -- + * + * Procedure called to compile the "set" command. + * + * Results: + * The return value is a standard Tcl result, which is normally TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. If + * complation fails because the set command requires a second level of + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the + * set command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_SetCmd) at runtime. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the incr command. + * + * Side effects: + * Instructions are added to envPtr to evaluate the "set" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileSetCmd(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Proc *procPtr = envPtr->procPtr; + /* Points to structure describing procedure + * containing the set command, else NULL. */ + ArgInfo argInfo; /* Structure holding information about the + * start and end of each argument word. */ + int simpleVarName; /* 1 if name is just sequence of chars with + * an optional element name in parens. */ + char *elName = NULL; /* If simpleVarName, points to first char of + * element name and elNameChars is length. + * Otherwise NULL. */ + int isAssignment; /* 1 if assigning value to var, else 0. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute cmd. */ + int localIndex = -1; /* Index of the variable in the current + * procedure's array of local variables. + * Otherwise -1 if not in a procedure, the + * name contains "::"s, or the variable + * wasn't found. */ + char savedChar; /* Holds the character from string + * termporarily replaced by a null char + * during name processing. */ + int objIndex = -1; /* The object array index for a pushed + * object holding a name part. Initialized + * to avoid a compiler warning. */ + char *wordStart, *p; + int numWords, isCompilableInt, i, result; + Tcl_Obj *objPtr; + int savePushSimpleWords = envPtr->pushSimpleWords; + + /* + * Scan the words of the command and record the start and finish of + * each argument word. + */ + + InitArgInfo(&argInfo); + result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); + numWords = argInfo.numArgs; /* i.e., the # after the command name */ + if (result != TCL_OK) { + goto done; + } + if ((numWords < 1) || (numWords > 2)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"set varName ?newValue?\"", -1); + result = TCL_ERROR; + goto done; + } + isAssignment = (numWords == 2); + + /* + * Parse the next word: the variable name. If the name is enclosed in + * quotes or braces, we return TCL_OUT_LINE_COMPILE and call the set + * command procedure at runtime since this makes sure that a second + * round of substitutions is done properly. + */ + + wordStart = argInfo.startArray[0]; /* start of 1st arg word: varname */ + if ((*wordStart == '{') || (*wordStart == '"')) { + result = TCL_OUT_LINE_COMPILE; + goto done; + } + + /* + * Check whether the name is "simple": requires no substitutions at + * runtime. + */ + + envPtr->pushSimpleWords = 0; + result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1, + flags, envPtr); + if (result != TCL_OK) { + goto done; + } + simpleVarName = envPtr->wordIsSimple; + + if (!simpleVarName) { + /* + * The name isn't simple. CompileWord already pushed it. + */ + + maxDepth = envPtr->maxStackDepth; + } else { + char *name; /* If simpleVarName, points to first char of + * variable name and nameChars is length. + * Otherwise NULL. */ + int nameChars; /* Length of the var name. */ + int nameHasNsSeparators = 0; + /* Set 1 if name contains "::"s. */ + int elNameChars; /* Length of array's element name if any. */ + + /* + * A simple name. First divide it up into "name" plus "elName" + * for an array element name, if any. + */ + + name = wordStart; + nameChars = envPtr->numSimpleWordChars; + elName = NULL; + elNameChars = 0; + + p = name; + for (i = 0; i < nameChars; i++) { + if (*p == '(') { + char *openParen = p; + p = (name + nameChars-1); + if (*p == ')') { /* last char is ')' => array reference */ + nameChars = (openParen - name); + elName = openParen+1; + elNameChars = (p - elName); + } + break; + } + p++; + } + + /* + * Determine if name has any namespace separators (::'s). + */ + + p = name; + for (i = 0; i < nameChars; i++) { + if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { + nameHasNsSeparators = 1; + break; + } + p++; + } + + /* + * Now either push the name or determine its index in the array of + * local variables in a procedure frame. Note that if we are + * compiling a procedure the variable must be local unless its + * name has namespace separators ("::"s). Note also that global + * variables are implemented by a local variable that "points" to + * the real global. There are two cases: + * 1) We are not compiling a procedure body. Push the global + * variable's name and do the lookup at runtime. + * 2) We are compiling a procedure and the name has "::"s. + * Push the namespace variable's name and do the lookup at + * runtime. + * 3) We are compiling a procedure and the name has no "::"s. + * If the variable has already been allocated an local index, + * just look it up. If the variable is unknown and we are + * doing an assignment, allocate a new index. Otherwise, + * push the name and try to do the lookup at runtime. + */ + + if ((procPtr == NULL) || nameHasNsSeparators) { + savedChar = name[nameChars]; + name[nameChars] = '\0'; + objIndex = TclObjIndexForString(name, nameChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + name[nameChars] = savedChar; + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + } else { + localIndex = LookupCompiledLocal(name, nameChars, + /*createIfNew*/ isAssignment, + /*flagsIfCreated*/ + ((elName == NULL)? VAR_SCALAR : VAR_ARRAY), + envPtr->procPtr); + if (localIndex >= 0) { + maxDepth = 0; + } else { + savedChar = name[nameChars]; + name[nameChars] = '\0'; + objIndex = TclObjIndexForString(name, nameChars, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + name[nameChars] = savedChar; + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + } + } + + /* + * If we are dealing with a reference to an array element, push the + * array element. Perform substitutions on it, just as is done + * for quoted strings. + */ + + if (elName != NULL) { + savedChar = elName[elNameChars]; + elName[elNameChars] = '\0'; + envPtr->pushSimpleWords = 1; + result = TclCompileQuotes(interp, elName, elName+elNameChars, + 0, flags, envPtr); + elName[elNameChars] = savedChar; + if (result != TCL_OK) { + char msg[200]; + sprintf(msg, "\n (parsing index for array \"%.*s\")", + TclMin(nameChars, 100), name); + Tcl_AddObjErrorInfo(interp, msg, -1); + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + } + + /* + * If we are doing an assignment, push the new value. + */ + + if (isAssignment) { + wordStart = argInfo.startArray[1]; /* start of 2nd arg word */ + envPtr->pushSimpleWords = 0; /* we will handle simple words */ + result = CompileWord(interp, wordStart, argInfo.endArray[1] + 1, + flags, envPtr); + if (result != TCL_OK) { + goto done; + } + if (!envPtr->wordIsSimple) { + /* + * The value isn't simple. CompileWord already pushed it. + */ + + maxDepth += envPtr->maxStackDepth; + } else { + /* + * The value is simple. See if the word represents an integer + * whose formatted representation is the same as the word (e.g., + * this is true for 123 and -1 but not for 00005). If so, just + * push an integer object. + */ + + char buf[40]; + long n; + + p = wordStart; + if ((*wordStart == '"') || (*wordStart == '{')) { + p++; + } + savedChar = p[envPtr->numSimpleWordChars]; + p[envPtr->numSimpleWordChars] = '\0'; + isCompilableInt = 0; + if (TclLooksLikeInt(p)) { + int code = TclGetLong(interp, p, &n); + if (code == TCL_OK) { + TclFormatInt(buf, n); + if (strcmp(p, buf) == 0) { + isCompilableInt = 1; + objIndex = TclObjIndexForString(p, + envPtr->numSimpleWordChars, + /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); + objPtr = envPtr->objArrayPtr[objIndex]; + + Tcl_InvalidateStringRep(objPtr); + objPtr->internalRep.longValue = n; + objPtr->typePtr = &tclIntType; + } + } else { + Tcl_ResetResult(interp); + } + } + if (!isCompilableInt) { + objIndex = TclObjIndexForString(p, + envPtr->numSimpleWordChars, /*allocStrRep*/ 1, + /*inHeap*/ 0, envPtr); + } + p[envPtr->numSimpleWordChars] = savedChar; + TclEmitPush(objIndex, envPtr); + maxDepth += 1; + } + } + + /* + * Now emit instructions to set/retrieve the variable. + */ + + if (simpleVarName) { + if (elName == NULL) { /* scalar */ + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstUInt1((isAssignment? + INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), + localIndex, envPtr); + } else { + TclEmitInstUInt4((isAssignment? + INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), + localIndex, envPtr); + } + } else { + TclEmitOpcode((isAssignment? + INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), + envPtr); + } + } else { /* array */ + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstUInt1((isAssignment? + INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), + localIndex, envPtr); + } else { + TclEmitInstUInt4((isAssignment? + INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), + localIndex, envPtr); + } + } else { + TclEmitOpcode((isAssignment? + INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), + envPtr); + } + } + } else { /* non-simple variable name */ + TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); + } + + done: + if (numWords == 0) { + envPtr->termOffset = 0; + } else { + envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); + } + envPtr->pushSimpleWords = savePushSimpleWords; + envPtr->maxStackDepth = maxDepth; + FreeArgInfo(&argInfo); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileWhileCmd -- + * + * Procedure called to compile the "while" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If compilation failed because the command is too + * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned + * indicating that the while command should be compiled "out of line" + * by emitting code to invoke its command procedure at runtime. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "while" command. + * + * Side effects: + * Instructions are added to envPtr to evaluate the "while" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileWhileCmd(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + register char *src = string;/* Points to current source char. */ + register int type; /* Current char's CHAR_TYPE type. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute cmd. */ + int range = -1; /* Index in the ExceptionRange array of the + * ExceptionRange record for this loop. */ + JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse + * jump after test when its target PC is + * determined. */ + unsigned char *jumpPc; + int jumpDist, jumpBackDist, jumpBackOffset, objIndex, result; + int savePushSimpleWords = envPtr->pushSimpleWords; + + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type == TCL_COMMAND_END) { + badArgs: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"while test command\"", -1); + result = TCL_ERROR; + goto done; + } + + /* + * If the test expression is not enclosed in braces, don't compile + * the while inline. As a result of Tcl's two level substitution + * semantics for expressions, the expression might have a constant + * value that results in the loop never executing, or executing forever. + * Consider "set x 0; whie "$x > 5" {incr x}": the loop body + * should never be executed. + * NOTE: This is an overly aggressive test, since there are legitimate + * literals that could be compiled but aren't in braces. However, until + * the parser is integrated in 8.1, this is the simplest implementation. + */ + + if (*src != '{') { + result = TCL_OUT_LINE_COMPILE; + goto done; + } + + /* + * Create and initialize a ExceptionRange record to hold information + * about this loop. This is used to implement break and continue. + */ + + envPtr->excRangeDepth++; + envPtr->maxExcRangeDepth = + TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); + + range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); + envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset(); + + /* + * Compile the next word: the test expression. + */ + + envPtr->pushSimpleWords = 1; + result = CompileExprWord(interp, src, lastChar, flags, envPtr); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"while\" test expression)", -1); + } + goto done; + } + maxDepth = envPtr->maxStackDepth; + src += envPtr->termOffset; + + /* + * Emit the ifFalse jump that terminates the while if the test was + * false. We emit a one byte (relative) jump here, and replace it + * later with a four byte jump if the jump target is more than + * 127 bytes away. + */ + + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Compile the loop body word inline. Also register the loop body's + * starting PC offset and byte length in the its ExceptionRange record. + */ + + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type == TCL_COMMAND_END) { + goto badArgs; + } + + envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); + result = CompileCmdWordInline(interp, src, lastChar, + flags, envPtr); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"while\" body line %d)", interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + src += envPtr->termOffset; + envPtr->excRangeArrayPtr[range].numCodeBytes = + (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset); + + /* + * Discard the loop body's result. + */ + + TclEmitOpcode(INST_POP, envPtr); + + /* + * Emit the unconditional jump back to the test at the top of the + * loop. We generate a four byte jump if the distance to the while's + * test is greater than 120 bytes. This is conservative, and ensures + * that we won't have to replace this unconditional jump if we later + * need to replace the ifFalse jump with a four-byte jump. + */ + + jumpBackOffset = TclCurrCodeOffset(); + jumpBackDist = + (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr); + } + + /* + * Now that we know the target of the jumpFalse after the test, update + * it with the correct distance. If the distance is too great (more + * than 127 bytes), replace that jump with a four byte instruction and + * move the instructions after the jump down. + */ + + jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset); + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body's starting PC offset since it moved down. + */ + + envPtr->excRangeArrayPtr[range].codeOffset += 3; + + /* + * Update the distance for the unconditional jump back to the test + * at the top of the loop since it moved down 3 bytes too. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + if (jumpBackDist > 120) { + jumpBackDist += 3; + TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist, + jumpPc); + } else { + jumpBackDist += 3; + TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist, + jumpPc); + } + } + + /* + * The current PC offset (after the loop's body) is the loop's + * break target. + */ + + envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset(); + + /* + * Push an empty string object as the while command's result. + */ + + objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, + envPtr); + TclEmitPush(objIndex, envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + + /* + * Skip over white space until the end of the command. + */ + + type = CHAR_TYPE(src, lastChar); + if (type != TCL_COMMAND_END) { + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type != TCL_COMMAND_END) { + goto badArgs; + } + } + + done: + envPtr->termOffset = (src - string); + envPtr->pushSimpleWords = savePushSimpleWords; + envPtr->maxStackDepth = maxDepth; + if (range != -1) { + envPtr->excRangeDepth--; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileExprWord -- + * + * Procedure that compiles a Tcl expression in a command word. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while compiling string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "expr" word. + * + * Side effects: + * Instructions are added to envPtr to evaluate the expression word + * at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileExprWord(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + register char *src = string;/* Points to current source char. */ + register int type; /* Current char's CHAR_TYPE type. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute the expression. */ + int nestedCmd = (flags & TCL_BRACKET_TERM); + /* 1 if script being compiled is a nested + * command and is terminated by a ']'; + * otherwise 0. */ + char *first, *last; /* Points to the first and last significant + * characters of the word. */ + char savedChar; /* Holds the character termporarily replaced + * by a null character during compilation + * of the expression. */ + int inlineCode; /* 1 if inline "optimistic" code is + * emitted for the expression; else 0. */ + int range = -1; /* If we inline compile an un-{}'d + * expression, the index for its catch range + * record in the ExceptionRange array. + * Initialized to enable proper cleanup. */ + JumpFixup jumpFixup; /* Used to emit the "success" jump after + * the inline expression code. */ + char *p; + char c; + int savePushSimpleWords = envPtr->pushSimpleWords; + int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; + int saveExprIsComparison = envPtr->exprIsComparison; + int numChars, result; + + /* + * Skip over leading white space. + */ + + AdvanceToNextWord(src, envPtr); + src += envPtr->termOffset; + type = CHAR_TYPE(src, lastChar); + if (type == TCL_COMMAND_END) { + badArgs: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "malformed expression word", -1); + result = TCL_ERROR; + goto done; + } + + /* + * If the word is enclosed in {}s, we may strip them off and safely + * compile the expression into an inline sequence of instructions using + * TclCompileExpr. We know these instructions will have the right Tcl7.x + * expression semantics. + * + * Otherwise, if the word is not enclosed in {}s, we may need to call + * the expr command (Tcl_ExprObjCmd) at runtime. This recompiles the + * expression each time (typically) and so is slow. However, there are + * some circumstances where we can still compile inline instructions + * "optimistically" and check, during their execution, for double + * substitutions (these appear as nonnumeric operands). We check for any + * backslash or command substitutions. If none appear, and only variable + * substitutions are found, we generate inline instructions. + * + * For now, if the expression is not enclosed in {}s, we call the expr + * command at runtime if either command or backslash substitutions + * appear (but not if only variable substitutions appear). + */ + + if (*src == '{') { + /* + * Inline compile the expression inside {}s. + */ + + first = src+1; + src = TclWordEnd(src, lastChar, nestedCmd, NULL); + if (*src == 0) { + goto badArgs; + } + if (*src != '}') { + goto badArgs; + } + last = (src-1); + + numChars = (last - first + 1); + savedChar = first[numChars]; + first[numChars] = '\0'; + result = TclCompileExpr(interp, first, first+numChars, + flags, envPtr); + first[numChars] = savedChar; + + src++; + maxDepth = envPtr->maxStackDepth; + } else { + /* + * No braces. If the expression is enclosed in '"'s, call the expr + * cmd at runtime. Otherwise, scan the word's characters looking for + * any '['s or (for now) '\'s. If any are found, just call expr cmd + * at runtime. + */ + + first = src; + last = TclWordEnd(first, lastChar, nestedCmd, NULL); + if (*last == 0) { /* word doesn't end properly. */ + src = last; + goto badArgs; + } + + inlineCode = 1; + if ((*first == '"') && (*last == '"')) { + inlineCode = 0; + } else { + for (p = first; p <= last; p++) { + c = *p; + if ((c == '[') || (c == '\\')) { + inlineCode = 0; + break; + } + } + } + + if (inlineCode) { + /* + * Inline compile the expression inside a "catch" so that a + * runtime error will back off to make a (slow) call on expr. + */ + + int startCodeOffset = (envPtr->codeNext - envPtr->codeStart); + int startRangeNext = envPtr->excRangeArrayNext; + + /* + * Create a ExceptionRange record to hold information about + * the "catch" range for the expression's inline code. Also + * emit the instruction to mark the start of the range. + */ + + envPtr->excRangeDepth++; + envPtr->maxExcRangeDepth = + TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); + range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr); + TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr); + + /* + * Inline compile the expression. + */ + + envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); + numChars = (last - first + 1); + savedChar = first[numChars]; + first[numChars] = '\0'; + result = TclCompileExpr(interp, first, first + numChars, + flags, envPtr); + first[numChars] = savedChar; + + envPtr->excRangeArrayPtr[range].numCodeBytes = + TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; + + if ((result != TCL_OK) || (envPtr->exprIsJustVarRef) + || (envPtr->exprIsComparison)) { + /* + * We must call the expr command at runtime. Either there + * was a compilation error or the inline code might fail to + * give the correct 2 level substitution semantics. + * + * The latter can happen if the expression consisted of just + * a single variable reference or if the top-level operator + * in the expr is a comparison (which might operate on + * strings). In the latter case, the expression's code might + * execute (apparently) successfully but produce the wrong + * result. We depend on its execution failing if a second + * level of substitutions is required. This causes the + * "catch" code we generate around the inline code to back + * off to a call on the expr command at runtime, and this + * always gives the right 2 level substitution semantics. + * + * We delete the inline code by backing up the code pc and + * catch index. Note that if there was a compilation error, + * we can't report the error yet since the expression might + * be valid after the second round of substitutions. + */ + + envPtr->codeNext = (envPtr->codeStart + startCodeOffset); + envPtr->excRangeArrayNext = startRangeNext; + inlineCode = 0; + } else { + TclEmitOpcode(INST_END_CATCH, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset(); + } + } + + /* + * Arrange to call expr at runtime with the (already substituted + * once) expression word on the stack. + */ + + envPtr->pushSimpleWords = 1; + result = CompileWord(interp, first, lastChar, flags, envPtr); + src += envPtr->termOffset; + maxDepth = envPtr->maxStackDepth; + if (result == TCL_OK) { + TclEmitOpcode(INST_EXPR_STK, envPtr); + } + + /* + * If emitting inline code for this non-{}'d expression, update + * the target of the jump after that inline code. + */ + + if (inlineCode) { + int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); + if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { + /* + * Update the inline expression code's catch ExceptionRange + * target since it, being after the jump, also moved down. + */ + + envPtr->excRangeArrayPtr[range].catchOffset += 3; + } + } + } /* if expression isn't in {}s */ + + done: + if (range != -1) { + envPtr->excRangeDepth--; + } + envPtr->termOffset = (src - string); + envPtr->maxStackDepth = maxDepth; + envPtr->pushSimpleWords = savePushSimpleWords; + envPtr->exprIsJustVarRef = saveExprIsJustVarRef; + envPtr->exprIsComparison = saveExprIsComparison; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CompileCmdWordInline -- + * + * Procedure that compiles a Tcl command word inline. If the word is + * enclosed in quotes or braces, we call TclCompileString to compile it + * after stripping them off. Otherwise, we normally push the word's + * value and call eval at runtime, but if the word is just a sequence + * of alphanumeric characters, we emit an invoke instruction + * directly. This procedure assumes that string points to the start of + * the word to compile. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while compiling string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->termOffset is filled in with the offset of the character in + * "string" just after the last one successfully processed. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the command word + * at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileCmdWordInline(interp, string, lastChar, flags, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to compile. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Interp *iPtr = (Interp *) interp; + register char *src = string;/* Points to current source char. */ + register int type; /* Current char's CHAR_TYPE type. */ + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute cmd. */ + char *termPtr; /* Points to char that terminated braced + * string. */ + char savedChar; /* Holds the character termporarily replaced + * by a null character during compilation + * of the command. */ + int savePushSimpleWords = envPtr->pushSimpleWords; + int objIndex; + int result = TCL_OK; + register char c; + + type = CHAR_TYPE(src, lastChar); + if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { + src++; + envPtr->pushSimpleWords = 0; + if (type == TCL_QUOTE) { + result = TclCompileQuotes(interp, src, lastChar, + '"', flags, envPtr); + } else { + result = CompileBraces(interp, src, lastChar, flags, envPtr); + } + if (result != TCL_OK) { + goto done; + } + + /* + * Make sure the terminating character is the end of word. + */ + + termPtr = (src + envPtr->termOffset); + c = *termPtr; + if ((c == '\\') && (*(termPtr+1) == '\n')) { + /* + * Line is continued on next line; the backslash-newline turns + * into space, which terminates the word. + */ + } else { + type = CHAR_TYPE(termPtr, lastChar); + if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) { + Tcl_ResetResult(interp); + if (*(src-1) == '"') { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "extra characters after close-quote", -1); + } else { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "extra characters after close-brace", -1); + } + result = TCL_ERROR; + goto done; + } + } + + if (envPtr->wordIsSimple) { + /* + * A simple word enclosed in "" or {}s. Call TclCompileString to + * compile it inline. Add a null character after the end of the + * quoted or braced string: i.e., at the " or }. Turn the + * flag bit TCL_BRACKET_TERM off since the recursively + * compiled subcommand is now terminated by a null character. + */ + char *closeCharPos = (termPtr - 1); + + savedChar = *closeCharPos; + *closeCharPos = '\0'; + result = TclCompileString(interp, src, closeCharPos, + (flags & ~TCL_BRACKET_TERM), envPtr); + *closeCharPos = savedChar; + if (result != TCL_OK) { + goto done; + } + } else { + /* + * The braced string contained a backslash-newline. Call eval + * at runtime. + */ + TclEmitOpcode(INST_EVAL_STK, envPtr); + } + src = termPtr; + maxDepth = envPtr->maxStackDepth; + } else { + /* + * Not a braced or quoted string. We normally push the word's + * value and call eval at runtime. However, if the word is just + * a sequence of alphanumeric characters, we call its compile + * procedure, if any, or otherwise just emit an invoke instruction. + */ + + char *p = src; + c = *p; + while (isalnum(UCHAR(c)) || (c == '_')) { + p++; + c = *p; + } + type = CHAR_TYPE(p, lastChar); + if ((p > src) && (type == TCL_COMMAND_END)) { + /* + * Look for a compile procedure and call it. Otherwise emit an + * invoke instruction to call the command at runtime. + */ + + Tcl_Command cmd; + Command *cmdPtr = NULL; + int wasCompiled = 0; + + savedChar = *p; + *p = '\0'; + + cmd = Tcl_FindCommand(interp, src, (Tcl_Namespace *) NULL, + /*flags*/ 0); + if (cmd != (Tcl_Command) NULL) { + cmdPtr = (Command *) cmd; + } + if (cmdPtr != NULL && cmdPtr->compileProc != NULL) { + *p = savedChar; + src = p; + iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS + | ERROR_CODE_SET); + result = (*(cmdPtr->compileProc))(interp, src, lastChar, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + wasCompiled = 1; + src += envPtr->termOffset; + maxDepth = envPtr->maxStackDepth; + } + if (!wasCompiled) { + objIndex = TclObjIndexForString(src, p-src, + /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + *p = savedChar; + TclEmitPush(objIndex, envPtr); + TclEmitInstUInt1(INST_INVOKE_STK1, 1, envPtr); + src = p; + maxDepth = 1; + } + } else { + /* + * Push the word and call eval at runtime. + */ + + envPtr->pushSimpleWords = 1; + result = CompileWord(interp, src, lastChar, flags, envPtr); + if (result != TCL_OK) { + goto done; + } + TclEmitOpcode(INST_EVAL_STK, envPtr); + src += envPtr->termOffset; + maxDepth = envPtr->maxStackDepth; + } + } + + done: + envPtr->termOffset = (src - string); + envPtr->maxStackDepth = maxDepth; + envPtr->pushSimpleWords = savePushSimpleWords; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * LookupCompiledLocal -- + * + * This procedure is called at compile time to look up and optionally + * allocate an entry ("slot") for a variable in a procedure's array of + * local variables. If the variable's name is NULL, a new temporary + * variable is always created. (Such temporary variables can only be + * referenced using their slot index.) + * + * Results: + * If createIfNew is 0 (false) and the name is non-NULL, then if the + * variable is found, the index of its entry in the procedure's array + * of local variables is returned; otherwise -1 is returned. + * If name is NULL, the index of a new temporary variable is returned. + * Finally, if createIfNew is 1 and name is non-NULL, the index of a + * new entry is returned. + * + * Side effects: + * Creates and registers a new local variable if createIfNew is 1 and + * the variable is unknown, or if the name is NULL. + * + *---------------------------------------------------------------------- + */ + +static int +LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr) + register char *name; /* Points to first character of the name of + * a scalar or array variable. If NULL, a + * temporary var should be created. */ + int nameChars; /* The length of the name excluding the + * terminating null character. */ + int createIfNew; /* 1 to allocate a local frame entry for the + * variable if it is new. */ + int flagsIfCreated; /* Flag bits for the compiled local if + * created. Only VAR_SCALAR, VAR_ARRAY, and + * VAR_LINK make sense. */ + register Proc *procPtr; /* Points to structure describing procedure + * containing the variable reference. */ +{ + register CompiledLocal *localPtr; + int localIndex = -1; + register int i; + int localCt; + + /* + * If not creating a temporary, does a local variable of the specified + * name already exist? + */ + + if (name != NULL) { + localCt = procPtr->numCompiledLocals; + localPtr = procPtr->firstLocalPtr; + for (i = 0; i < localCt; i++) { + if (!TclIsVarTemporary(localPtr)) { + char *localName = localPtr->name; + if ((name[0] == localName[0]) + && (nameChars == localPtr->nameLength) + && (strncmp(name, localName, (unsigned) nameChars) == 0)) { + return i; + } + } + localPtr = localPtr->nextPtr; + } + } + + /* + * Create a new variable if appropriate. + */ + + if (createIfNew || (name == NULL)) { + localIndex = procPtr->numCompiledLocals; + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameChars+1)); + if (procPtr->firstLocalPtr == NULL) { + procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; + } else { + procPtr->lastLocalPtr->nextPtr = localPtr; + procPtr->lastLocalPtr = localPtr; + } + localPtr->nextPtr = NULL; + localPtr->nameLength = nameChars; + localPtr->frameIndex = localIndex; + localPtr->flags = flagsIfCreated; + if (name == NULL) { + localPtr->flags |= VAR_TEMPORARY; + } + localPtr->defValuePtr = NULL; + localPtr->resolveInfo = NULL; + + if (name != NULL) { + memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars); + } + localPtr->name[nameChars] = '\0'; + procPtr->numCompiledLocals++; + } + return localIndex; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitCompiledLocals -- + * + * This routine is invoked in order to initialize the compiled + * locals table for a new call frame. + * + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + +void +TclInitCompiledLocals(interp, framePtr, nsPtr) + Tcl_Interp *interp; /* Current interpreter. */ + CallFrame *framePtr; /* Call frame to initialize. */ + Namespace *nsPtr; /* Pointer to current namespace. */ +{ + register CompiledLocal *localPtr; + Interp *iPtr = (Interp*) interp; + Tcl_ResolvedVarInfo *vinfo, *resVarInfo; + Var *varPtr = framePtr->compiledLocals; + Var *resolvedVarPtr; + ResolverScheme *resPtr; + int result; + + /* + * Initialize the array of local variables stored in the call frame. + * Some variables may have special resolution rules. In that case, + * we call their "resolver" procs to get our hands on the variable, + * and we make the compiled local a link to the real variable. + */ + + for (localPtr = framePtr->procPtr->firstLocalPtr; + localPtr != NULL; + localPtr = localPtr->nextPtr) { + + /* + * Check to see if this local is affected by namespace or + * interp resolvers. The resolver to use is cached for the + * next invocation of the procedure. + */ + + if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED)) + && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) { + resPtr = iPtr->resolverPtr; + + if (nsPtr->compiledVarResProc) { + result = (*nsPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } else { + result = TCL_CONTINUE; + } + + while ((result == TCL_CONTINUE) && resPtr) { + if (resPtr->compiledVarResProc) { + result = (*resPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } + resPtr = resPtr->nextPtr; + } + if (result == TCL_OK) { + localPtr->resolveInfo = vinfo; + localPtr->flags |= VAR_RESOLVED; + } + } + + /* + * Now invoke the resolvers to determine the exact variables that + * should be used. + */ + + resVarInfo = localPtr->resolveInfo; + resolvedVarPtr = NULL; + + if (resVarInfo && resVarInfo->fetchProc) { + resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, + resVarInfo); + } + + if (resolvedVarPtr) { + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = 0; + TclSetVarLink(varPtr); + varPtr->value.linkPtr = resolvedVarPtr; + resolvedVarPtr->refCount++; + } else { + varPtr->value.objPtr = NULL; + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = (localPtr->flags | VAR_UNDEFINED); + } + varPtr++; + } +} + +/* + *---------------------------------------------------------------------- + * + * AdvanceToNextWord -- + * + * This procedure is called to skip over any leading white space at the + * start of a word. Note that a backslash-newline is treated as a + * space. + * + * Results: + * None. + * + * Side effects: + * Updates envPtr->termOffset with the offset of the first + * character in "string" that was not white space or a + * backslash-newline. This might be the offset of the character that + * ends the command: a newline, null, semicolon, or close-bracket. + * + *---------------------------------------------------------------------- + */ + +static void +AdvanceToNextWord(string, envPtr) + char *string; /* The source string to compile. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + register char *src; /* Points to current source char. */ + register int type; /* Current char's CHAR_TYPE type. */ + + src = string; + type = CHAR_TYPE(src, src+1); + while (type & (TCL_SPACE | TCL_BACKSLASH)) { + if (type == TCL_BACKSLASH) { + if (src[1] == '\n') { + src += 2; + } else { + break; /* exit loop; no longer white space */ + } + } else { + src++; + } + type = CHAR_TYPE(src, src+1); + } + envPtr->termOffset = (src - string); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Backslash -- + * + * Figure out how to handle a backslash sequence. + * + * Results: + * The return value is the character that should be substituted + * in place of the backslash sequence that starts at src. If + * readPtr isn't NULL then it is filled in with a count of the + * number of characters in the backslash sequence. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char +Tcl_Backslash(src, readPtr) + CONST char *src; /* Points to the backslash character of + * a backslash sequence. */ + int *readPtr; /* Fill in with number of characters read + * from src, unless NULL. */ +{ + CONST char *p = src + 1; + char result; + int count; + + count = 2; + + switch (*p) { + /* + * Note: in the conversions below, use absolute values (e.g., + * 0xa) rather than symbolic values (e.g. \n) that get converted + * by the compiler. It's possible that compilers on some + * platforms will do the symbolic conversions differently, which + * could result in non-portable Tcl scripts. + */ + + case 'a': + result = 0x7; + break; + case 'b': + result = 0x8; + break; + case 'f': + result = 0xc; + break; + case 'n': + result = 0xa; + break; + case 'r': + result = 0xd; + break; + case 't': + result = 0x9; + break; + case 'v': + result = 0xb; + break; + case 'x': + if (isxdigit(UCHAR(p[1]))) { + char *end; + + result = (char) strtoul(p+1, &end, 16); + count = end - src; + } else { + count = 2; + result = 'x'; + } + break; + case '\n': + do { + p++; + } while ((*p == ' ') || (*p == '\t')); + result = ' '; + count = p - src; + break; + case 0: + result = '\\'; + count = 1; + break; + default: + if (isdigit(UCHAR(*p))) { + result = (char)(*p - '0'); + p++; + if (!isdigit(UCHAR(*p))) { + break; + } + count = 3; + result = (char)((result << 3) + (*p - '0')); + p++; + if (!isdigit(UCHAR(*p))) { + break; + } + count = 4; + result = (char)((result << 3) + (*p - '0')); + break; + } + result = *p; + count = 2; + break; + } + + if (readPtr != NULL) { + *readPtr = count; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclObjIndexForString -- + * + * Procedure to find, or if necessary create, an object in a + * CompileEnv's object array that has a string representation + * matching the argument string. + * + * Results: + * The index in the CompileEnv's object array of an object with a + * string representation matching the argument "string". The object is + * created if necessary. If inHeap is 1, then string is heap allocated + * and ownership of the string is passed to TclObjIndexForString; + * otherwise, the string is owned by the caller and must not be + * modified or freed by TclObjIndexForString. Typically, a caller sets + * inHeap 1 if string is an already heap-allocated buffer holding the + * result of backslash substitutions. + * + * Side effects: + * A new Tcl object will be created if no existing object matches the + * input string. If allocStrRep is 1 then if a new object is created, + * its string representation is allocated in the heap, else it is left + * NULL. If inHeap is 1, this procedure is given ownership of the + * string: if an object is created and allocStrRep is 1 then its + * string representation is set directly from string, otherwise + * the string is freed. + * + *---------------------------------------------------------------------- + */ + +int +TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr) + register char *string; /* Points to string for which an object is + * found or created in CompileEnv's object + * array. */ + int length; /* Length of string. */ + int allocStrRep; /* If 1 then the object's string rep should + * be allocated in the heap. */ + int inHeap; /* If 1 then string is heap allocated and + * its ownership is passed to + * TclObjIndexForString. */ + CompileEnv *envPtr; /* Points to the CompileEnv in whose object + * array an object is found or created. */ +{ + register Tcl_Obj *objPtr; /* Points to the object created for + * the string, if one was created. */ + int objIndex; /* Index of matching object. */ + Tcl_HashEntry *hPtr; + int strLength, new; + + /* + * Look up the string in the code's object hashtable. If found, just + * return the associated object array index. Note that if the string + * has embedded nulls, we don't create a hash table entry. This + * should be fixed, but we need to update hash tables, first. + */ + + strLength = strlen(string); + if (length == -1) { + length = strLength; + } + if (strLength != length) { + hPtr = NULL; + } else { + hPtr = Tcl_CreateHashEntry(&envPtr->objTable, string, &new); + if (!new) { /* already in object table and array */ + objIndex = (int) Tcl_GetHashValue(hPtr); + if (inHeap) { + ckfree(string); + } + return objIndex; + } + } + + /* + * Create a new object holding the string, add it to the object array, + * and register its index in the object hashtable. + */ + + objPtr = Tcl_NewObj(); + if (allocStrRep) { + if (inHeap) { /* use input string for obj's string rep */ + objPtr->bytes = string; + } else { + if (length > 0) { + objPtr->bytes = ckalloc((unsigned) length + 1); + memcpy((VOID *) objPtr->bytes, (VOID *) string, + (size_t) length); + objPtr->bytes[length] = '\0'; + } + } + objPtr->length = length; + } else { /* leave the string rep NULL */ + if (inHeap) { + ckfree(string); + } + } + + if (envPtr->objArrayNext >= envPtr->objArrayEnd) { + ExpandObjectArray(envPtr); + } + objIndex = envPtr->objArrayNext; + envPtr->objArrayPtr[objIndex] = objPtr; + Tcl_IncrRefCount(objPtr); + envPtr->objArrayNext++; + + if (hPtr) { + Tcl_SetHashValue(hPtr, objIndex); + } + return objIndex; +} + +/* + *---------------------------------------------------------------------- + * + * TclExpandCodeArray -- + * + * Procedure that uses malloc to allocate more storage for a + * CompileEnv's code array. + * + * Results: + * None. + * + * Side effects: + * The byte code array in *envPtr is reallocated to a new array of + * double the size, and if envPtr->mallocedCodeArray is non-zero the + * old array is freed. Byte codes are copied from the old array to the + * new one. + * + *---------------------------------------------------------------------- + */ + +void +TclExpandCodeArray(envPtr) + CompileEnv *envPtr; /* Points to the CompileEnv whose code array + * must be enlarged. */ +{ + /* + * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined + * code bytes are stored between envPtr->codeStart and + * (envPtr->codeNext - 1) [inclusive]. + */ + + size_t currBytes = TclCurrCodeOffset(); + size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); + unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); + + /* + * Copy from old code array to new, free old code array if needed, and + * mark new code array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes); + if (envPtr->mallocedCodeArray) { + ckfree((char *) envPtr->codeStart); + } + envPtr->codeStart = newPtr; + envPtr->codeNext = (newPtr + currBytes); + envPtr->codeEnd = (newPtr + newBytes); + envPtr->mallocedCodeArray = 1; +} + +/* + *---------------------------------------------------------------------- + * + * ExpandObjectArray -- + * + * Procedure that uses malloc to allocate more storage for a + * CompileEnv's object array. + * + * Results: + * None. + * + * Side effects: + * The object array in *envPtr is reallocated to a new array of + * double the size, and if envPtr->mallocedObjArray is non-zero the + * old array is freed. Tcl_Obj pointers are copied from the old array + * to the new one. + * + *---------------------------------------------------------------------- + */ + +static void +ExpandObjectArray(envPtr) + CompileEnv *envPtr; /* Points to the CompileEnv whose object + * array must be enlarged. */ +{ + /* + * envPtr->objArrayNext is equal to envPtr->objArrayEnd. The currently + * allocated Tcl_Obj pointers are stored between elements + * 0 and (envPtr->objArrayNext - 1) [inclusive] in the object array + * pointed to by objArrayPtr. + */ + + size_t currBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *); + int newElems = 2*envPtr->objArrayEnd; + size_t newBytes = newElems * sizeof(Tcl_Obj *); + Tcl_Obj **newPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); + + /* + * Copy from old object array to new, free old object array if needed, + * and mark new object array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->objArrayPtr, currBytes); + if (envPtr->mallocedObjArray) { + ckfree((char *) envPtr->objArrayPtr); + } + envPtr->objArrayPtr = (Tcl_Obj **) newPtr; + envPtr->objArrayEnd = newElems; + envPtr->mallocedObjArray = 1; +} + +/* + *---------------------------------------------------------------------- + * + * EnterCmdStartData -- + * + * Registers the starting source and bytecode location of a + * command. This information is used at runtime to map between + * instruction pc and source locations. + * + * Results: + * None. + * + * Side effects: + * Inserts source and code location information into the compilation + * environment envPtr for the command at index cmdIndex. The + * compilation environment's CmdLocation array is grown if necessary. + * + *---------------------------------------------------------------------- + */ + +static void +EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) + CompileEnv *envPtr; /* Points to the compilation environment + * structure in which to enter command + * location information. */ + int cmdIndex; /* Index of the command whose start data + * is being set. */ + int srcOffset; /* Offset of first char of the command. */ + int codeOffset; /* Offset of first byte of command code. */ +{ + CmdLocation *cmdLocPtr; + + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { + panic("EnterCmdStartData: bad command index %d\n", cmdIndex); + } + + if (cmdIndex >= envPtr->cmdMapEnd) { + /* + * Expand the command location array by allocating more storage from + * the heap. The currently allocated CmdLocation entries are stored + * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive). + */ + + size_t currElems = envPtr->cmdMapEnd; + size_t newElems = 2*currElems; + size_t currBytes = currElems * sizeof(CmdLocation); + size_t newBytes = newElems * sizeof(CmdLocation); + CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); + + /* + * Copy from old command location array to new, free old command + * location array if needed, and mark new array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes); + if (envPtr->mallocedCmdMap) { + ckfree((char *) envPtr->cmdMapPtr); + } + envPtr->cmdMapPtr = (CmdLocation *) newPtr; + envPtr->cmdMapEnd = newElems; + envPtr->mallocedCmdMap = 1; + } + + if (cmdIndex > 0) { + if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { + panic("EnterCmdStartData: cmd map table not sorted by code offset"); + } + } + + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); + cmdLocPtr->codeOffset = codeOffset; + cmdLocPtr->srcOffset = srcOffset; + cmdLocPtr->numSrcChars = -1; + cmdLocPtr->numCodeBytes = -1; +} + +/* + *---------------------------------------------------------------------- + * + * EnterCmdExtentData -- + * + * Registers the source and bytecode length for a command. This + * information is used at runtime to map between instruction pc and + * source locations. + * + * Results: + * None. + * + * Side effects: + * Inserts source and code length information into the compilation + * environment envPtr for the command at index cmdIndex. Starting + * source and bytecode information for the command must already + * have been registered. + * + *---------------------------------------------------------------------- + */ + +static void +EnterCmdExtentData(envPtr, cmdIndex, numSrcChars, numCodeBytes) + CompileEnv *envPtr; /* Points to the compilation environment + * structure in which to enter command + * location information. */ + int cmdIndex; /* Index of the command whose source and + * code length data is being set. */ + int numSrcChars; /* Number of command source chars. */ + int numCodeBytes; /* Offset of last byte of command code. */ +{ + CmdLocation *cmdLocPtr; + + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { + panic("EnterCmdStartData: bad command index %d\n", cmdIndex); + } + + if (cmdIndex > envPtr->cmdMapEnd) { + panic("EnterCmdStartData: no start data registered for command with index %d\n", cmdIndex); + } + + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); + cmdLocPtr->numSrcChars = numSrcChars; + cmdLocPtr->numCodeBytes = numCodeBytes; +} + +/* + *---------------------------------------------------------------------- + * + * InitArgInfo -- + * + * Initializes a ArgInfo structure to hold information about + * some number of argument words in a command. + * + * Results: + * None. + * + * Side effects: + * The ArgInfo structure is initialized. + * + *---------------------------------------------------------------------- + */ + +static void +InitArgInfo(argInfoPtr) + register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure + * to initialize. */ +{ + argInfoPtr->numArgs = 0; + argInfoPtr->startArray = argInfoPtr->staticStartSpace; + argInfoPtr->endArray = argInfoPtr->staticEndSpace; + argInfoPtr->allocArgs = ARGINFO_INIT_ENTRIES; + argInfoPtr->mallocedArrays = 0; +} + +/* + *---------------------------------------------------------------------- + * + * CollectArgInfo -- + * + * Procedure to scan the argument words of a command and record the + * start and finish of each argument word in a ArgInfo structure. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while scanning string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * Side effects: + * If necessary, the argument start and end arrays in *argInfoPtr + * are grown and reallocated to a new arrays of double the size, and + * if argInfoPtr->mallocedArray is non-zero the old arrays are freed. + * + *---------------------------------------------------------------------- + */ + +static int +CollectArgInfo(interp, string, lastChar, flags, argInfoPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source command string to scan. */ + char *lastChar; /* Pointer to terminating character of + * string. */ + int flags; /* Flags to control compilation (same as + * passed to Tcl_Eval). */ + register ArgInfo *argInfoPtr; + /* Points to the ArgInfo structure in which + * to record the arg word information. */ +{ + register char *src = string;/* Points to current source char. */ + register int type; /* Current char's CHAR_TYPE type. */ + int nestedCmd = (flags & TCL_BRACKET_TERM); + /* 1 if string being scanned is a nested + * command and is terminated by a ']'; + * otherwise 0. */ + int scanningArgs; /* 1 if still scanning argument words to + * determine their start and end. */ + char *wordStart, *wordEnd; /* Points to the first and last significant + * characters of each word. */ + CompileEnv tempCompEnv; /* Only used to hold the termOffset field + * updated by AdvanceToNextWord. */ + char *prev; + + argInfoPtr->numArgs = 0; + scanningArgs = 1; + while (scanningArgs) { + AdvanceToNextWord(src, &tempCompEnv); + src += tempCompEnv.termOffset; + type = CHAR_TYPE(src, lastChar); + + if ((type == TCL_COMMAND_END) && ((*src != ']') || nestedCmd)) { + break; /* done collecting argument words */ + } else if (*src == '"') { + wordStart = src; + src = TclWordEnd(src, lastChar, nestedCmd, NULL); + if (src == lastChar) { + badStringTermination: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "quoted string doesn't terminate properly", -1); + return TCL_ERROR; + } + prev = (src-1); + if (*src == '"') { + wordEnd = src; + src++; + } else if ((*src == ';') && (*prev == '"')) { + scanningArgs = 0; + wordEnd = prev; + } else { + goto badStringTermination; + } + } else if (*src == '{') { + wordStart = src; + src = TclWordEnd(src, lastChar, nestedCmd, NULL); + if (src == lastChar) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "missing close-brace", -1); + return TCL_ERROR; + } + prev = (src-1); + if (*src == '}') { + wordEnd = src; + src++; + } else if ((*src == ';') && (*prev == '}')) { + scanningArgs = 0; + wordEnd = prev; + } else { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument word in braces doesn't terminate properly", -1); + return TCL_ERROR; + } + } else { + wordStart = src; + src = TclWordEnd(src, lastChar, nestedCmd, NULL); + prev = (src-1); + if (src == lastChar) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "missing close-bracket or close-brace", -1); + return TCL_ERROR; + } else if (*src == ';') { + scanningArgs = 0; + wordEnd = prev; + } else { + wordEnd = src; + src++; + if ((src == lastChar) || (*src == '\n') + || ((*src == ']') && nestedCmd)) { + scanningArgs = 0; + } + } + } /* end of test on each kind of word */ + + if (argInfoPtr->numArgs == argInfoPtr->allocArgs) { + int newArgs = 2*argInfoPtr->numArgs; + size_t currBytes = argInfoPtr->numArgs * sizeof(char *); + size_t newBytes = newArgs * sizeof(char *); + char **newStartArrayPtr = + (char **) ckalloc((unsigned) newBytes); + char **newEndArrayPtr = + (char **) ckalloc((unsigned) newBytes); + + /* + * Copy from the old arrays to the new, free the old arrays if + * needed, and mark the new arrays as malloc'ed. + */ + + memcpy((VOID *) newStartArrayPtr, + (VOID *) argInfoPtr->startArray, currBytes); + memcpy((VOID *) newEndArrayPtr, + (VOID *) argInfoPtr->endArray, currBytes); + if (argInfoPtr->mallocedArrays) { + ckfree((char *) argInfoPtr->startArray); + ckfree((char *) argInfoPtr->endArray); + } + argInfoPtr->startArray = newStartArrayPtr; + argInfoPtr->endArray = newEndArrayPtr; + argInfoPtr->allocArgs = newArgs; + argInfoPtr->mallocedArrays = 1; + } + argInfoPtr->startArray[argInfoPtr->numArgs] = wordStart; + argInfoPtr->endArray[argInfoPtr->numArgs] = wordEnd; + argInfoPtr->numArgs++; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FreeArgInfo -- + * + * Free any storage allocated in a ArgInfo structure. + * + * Results: + * None. + * + * Side effects: + * Allocated storage in the ArgInfo structure is freed. + * + *---------------------------------------------------------------------- + */ + +static void +FreeArgInfo(argInfoPtr) + register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure + * to free. */ +{ + if (argInfoPtr->mallocedArrays) { + ckfree((char *) argInfoPtr->startArray); + ckfree((char *) argInfoPtr->endArray); + } +} + +/* + *---------------------------------------------------------------------- + * + * CreateExceptionRange -- + * + * Procedure that allocates and initializes a new ExceptionRange + * structure of the specified kind in a CompileEnv's ExceptionRange + * array. + * + * Results: + * Returns the index for the newly created ExceptionRange. + * + * Side effects: + * If there is not enough room in the CompileEnv's ExceptionRange + * array, the array in expanded: a new array of double the size is + * allocated, if envPtr->mallocedExcRangeArray is non-zero the old + * array is freed, and ExceptionRange entries are copied from the old + * array to the new one. + * + *---------------------------------------------------------------------- + */ + +static int +CreateExceptionRange(type, envPtr) + ExceptionRangeType type; /* The kind of ExceptionRange desired. */ + register CompileEnv *envPtr;/* Points to the CompileEnv for which a new + * loop ExceptionRange structure is to be + * allocated. */ +{ + int index; /* Index for the newly-allocated + * ExceptionRange structure. */ + register ExceptionRange *rangePtr; + /* Points to the new ExceptionRange + * structure */ + + index = envPtr->excRangeArrayNext; + if (index >= envPtr->excRangeArrayEnd) { + /* + * Expand the ExceptionRange array. The currently allocated entries + * are stored between elements 0 and (envPtr->excRangeArrayNext - 1) + * [inclusive]. + */ + + size_t currBytes = + envPtr->excRangeArrayNext * sizeof(ExceptionRange); + int newElems = 2*envPtr->excRangeArrayEnd; + size_t newBytes = newElems * sizeof(ExceptionRange); + ExceptionRange *newPtr = (ExceptionRange *) + ckalloc((unsigned) newBytes); + + /* + * Copy from old ExceptionRange array to new, free old + * ExceptionRange array if needed, and mark the new ExceptionRange + * array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->excRangeArrayPtr, + currBytes); + if (envPtr->mallocedExcRangeArray) { + ckfree((char *) envPtr->excRangeArrayPtr); + } + envPtr->excRangeArrayPtr = (ExceptionRange *) newPtr; + envPtr->excRangeArrayEnd = newElems; + envPtr->mallocedExcRangeArray = 1; + } + envPtr->excRangeArrayNext++; + + rangePtr = &(envPtr->excRangeArrayPtr[index]); + rangePtr->type = type; + rangePtr->nestingLevel = envPtr->excRangeDepth; + rangePtr->codeOffset = -1; + rangePtr->numCodeBytes = -1; + rangePtr->breakOffset = -1; + rangePtr->continueOffset = -1; + rangePtr->catchOffset = -1; + return index; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateAuxData -- + * + * Procedure that allocates and initializes a new AuxData structure in + * a CompileEnv's array of compilation auxiliary data records. These + * AuxData records hold information created during compilation by + * CompileProcs and used by instructions during execution. + * + * Results: + * Returns the index for the newly created AuxData structure. + * + * Side effects: + * If there is not enough room in the CompileEnv's AuxData array, + * the AuxData array in expanded: a new array of double the size + * is allocated, if envPtr->mallocedAuxDataArray is non-zero + * the old array is freed, and AuxData entries are copied from + * the old array to the new one. + * + *---------------------------------------------------------------------- + */ + +int +TclCreateAuxData(clientData, typePtr, envPtr) + ClientData clientData; /* The compilation auxiliary data to store + * in the new aux data record. */ + AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */ + register CompileEnv *envPtr;/* Points to the CompileEnv for which a new + * aux data structure is to be allocated. */ +{ + int index; /* Index for the new AuxData structure. */ + register AuxData *auxDataPtr; + /* Points to the new AuxData structure */ + + index = envPtr->auxDataArrayNext; + if (index >= envPtr->auxDataArrayEnd) { + /* + * Expand the AuxData array. The currently allocated entries are + * stored between elements 0 and (envPtr->auxDataArrayNext - 1) + * [inclusive]. + */ + + size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); + int newElems = 2*envPtr->auxDataArrayEnd; + size_t newBytes = newElems * sizeof(AuxData); + AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); + + /* + * Copy from old AuxData array to new, free old AuxData array if + * needed, and mark the new AuxData array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, + currBytes); + if (envPtr->mallocedAuxDataArray) { + ckfree((char *) envPtr->auxDataArrayPtr); + } + envPtr->auxDataArrayPtr = newPtr; + envPtr->auxDataArrayEnd = newElems; + envPtr->mallocedAuxDataArray = 1; + } + envPtr->auxDataArrayNext++; + + auxDataPtr = &(envPtr->auxDataArrayPtr[index]); + auxDataPtr->type = typePtr; + auxDataPtr->clientData = clientData; + return index; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitJumpFixupArray -- + * + * Initializes a JumpFixupArray structure to hold some number of + * jump fixup entries. + * + * Results: + * None. + * + * Side effects: + * The JumpFixupArray structure is initialized. + * + *---------------------------------------------------------------------- + */ + +void +TclInitJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to initialize. */ +{ + fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; + fixupArrayPtr->next = 0; + fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1); + fixupArrayPtr->mallocedArray = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclExpandJumpFixupArray -- + * + * Procedure that uses malloc to allocate more storage for a + * jump fixup array. + * + * Results: + * None. + * + * Side effects: + * The jump fixup array in *fixupArrayPtr is reallocated to a new array + * of double the size, and if fixupArrayPtr->mallocedArray is non-zero + * the old array is freed. Jump fixup structures are copied from the + * old array to the new one. + * + *---------------------------------------------------------------------- + */ + +void +TclExpandJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to enlarge. */ +{ + /* + * The currently allocated jump fixup entries are stored from fixup[0] + * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume + * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd. + */ + + size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); + int newElems = 2*(fixupArrayPtr->end + 1); + size_t newBytes = newElems * sizeof(JumpFixup); + JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); + + /* + * Copy from the old array to new, free the old array if needed, + * and mark the new array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes); + if (fixupArrayPtr->mallocedArray) { + ckfree((char *) fixupArrayPtr->fixup); + } + fixupArrayPtr->fixup = (JumpFixup *) newPtr; + fixupArrayPtr->end = newElems; + fixupArrayPtr->mallocedArray = 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclFreeJumpFixupArray -- + * + * Free any storage allocated in a jump fixup array structure. + * + * Results: + * None. + * + * Side effects: + * Allocated storage in the JumpFixupArray structure is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclFreeJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to free. */ +{ + if (fixupArrayPtr->mallocedArray) { + ckfree((char *) fixupArrayPtr->fixup); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclEmitForwardJump -- + * + * Procedure to emit a two-byte forward jump of kind "jumpType". Since + * the jump may later have to be grown to five bytes if the jump target + * is more than, say, 127 bytes away, this procedure also initializes a + * JumpFixup record with information about the jump. + * + * Results: + * None. + * + * Side effects: + * The JumpFixup record pointed to by "jumpFixupPtr" is initialized + * with information needed later if the jump is to be grown. Also, + * a two byte jump of the designated type is emitted at the current + * point in the bytecode stream. + * + *---------------------------------------------------------------------- + */ + +void +TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr) + CompileEnv *envPtr; /* Points to the CompileEnv structure that + * holds the resulting instruction. */ + TclJumpType jumpType; /* Indicates the kind of jump: if true or + * false or unconditional. */ + JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to + * initialize with information about this + * forward jump. */ +{ + /* + * Initialize the JumpFixup structure: + * - codeOffset is offset of first byte of jump below + * - cmdIndex is index of the command after the current one + * - excRangeIndex is the index of the first ExceptionRange after + * the current one. + */ + + jumpFixupPtr->jumpType = jumpType; + jumpFixupPtr->codeOffset = TclCurrCodeOffset(); + jumpFixupPtr->cmdIndex = envPtr->numCommands; + jumpFixupPtr->excRangeIndex = envPtr->excRangeArrayNext; + + switch (jumpType) { + case TCL_UNCONDITIONAL_JUMP: + TclEmitInstInt1(INST_JUMP1, /*offset*/ 0, envPtr); + break; + case TCL_TRUE_JUMP: + TclEmitInstInt1(INST_JUMP_TRUE1, /*offset*/ 0, envPtr); + break; + default: + TclEmitInstInt1(INST_JUMP_FALSE1, /*offset*/ 0, envPtr); + break; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclFixupForwardJump -- + * + * Procedure that updates a previously-emitted forward jump to jump + * a specified number of bytes, "jumpDist". If necessary, the jump is + * grown from two to five bytes; this is done if the jump distance is + * greater than "distThreshold" (normally 127 bytes). The jump is + * described by a JumpFixup record previously initialized by + * TclEmitForwardJump. + * + * Results: + * 1 if the jump was grown and subsequent instructions had to be moved; + * otherwise 0. This result is returned to allow callers to update + * any additional code offsets they may hold. + * + * Side effects: + * The jump may be grown and subsequent instructions moved. If this + * happens, the code offsets for any commands and any ExceptionRange + * records between the jump and the current code address will be + * updated to reflect the moved code. Also, the bytecode instruction + * array in the CompileEnv structure may be grown and reallocated. + * + *---------------------------------------------------------------------- + */ + +int +TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) + CompileEnv *envPtr; /* Points to the CompileEnv structure that + * holds the resulting instruction. */ + JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that + * describes the forward jump. */ + int jumpDist; /* Jump distance to set in jump + * instruction. */ + int distThreshold; /* Maximum distance before the two byte + * jump is grown to five bytes. */ +{ + unsigned char *jumpPc, *p; + int firstCmd, lastCmd, firstRange, lastRange, k; + unsigned int numBytes; + + if (jumpDist <= distThreshold) { + jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); + switch (jumpFixupPtr->jumpType) { + case TCL_UNCONDITIONAL_JUMP: + TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); + break; + case TCL_TRUE_JUMP: + TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc); + break; + default: + TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc); + break; + } + return 0; + } + + /* + * We must grow the jump then move subsequent instructions down. + */ + + TclEnsureCodeSpace(3, envPtr); /* NB: might change code addresses! */ + jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); + for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1; + numBytes > 0; numBytes--, p--) { + p[3] = p[0]; + } + envPtr->codeNext += 3; + jumpDist += 3; + switch (jumpFixupPtr->jumpType) { + case TCL_UNCONDITIONAL_JUMP: + TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc); + break; + case TCL_TRUE_JUMP: + TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc); + break; + default: + TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); + break; + } + + /* + * Adjust the code offsets for any commands and any ExceptionRange + * records between the jump and the current code address. + */ + + firstCmd = jumpFixupPtr->cmdIndex; + lastCmd = (envPtr->numCommands - 1); + if (firstCmd < lastCmd) { + for (k = firstCmd; k <= lastCmd; k++) { + (envPtr->cmdMapPtr[k]).codeOffset += 3; + } + } + + firstRange = jumpFixupPtr->excRangeIndex; + lastRange = (envPtr->excRangeArrayNext - 1); + for (k = firstRange; k <= lastRange; k++) { + ExceptionRange *rangePtr = &(envPtr->excRangeArrayPtr[k]); + rangePtr->codeOffset += 3; + + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + rangePtr->breakOffset += 3; + if (rangePtr->continueOffset != -1) { + rangePtr->continueOffset += 3; + } + break; + case CATCH_EXCEPTION_RANGE: + rangePtr->catchOffset += 3; + break; + default: + panic("TclFixupForwardJump: unrecognized ExceptionRange type %d\n", rangePtr->type); + } + } + return 1; /* the jump was grown */ +} + +/* + *---------------------------------------------------------------------- + * + * TclGetInstructionTable -- + * + * Returns a pointer to the table describing Tcl bytecode instructions. + * This procedure is defined so that clients can access the pointer from + * outside the TCL DLLs. + * + * Results: + * Returns a pointer to the global instruction table, same as the expression + * (&instructionTable[0]). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +InstructionDesc * +TclGetInstructionTable() +{ + return &instructionTable[0]; +} + +/* + *-------------------------------------------------------------- + * + * TclRegisterAuxDataType -- + * + * This procedure is called to register a new AuxData type + * in the table of all AuxData types supported by Tcl. + * + * Results: + * None. + * + * Side effects: + * The type is registered in the AuxData type table. If there was already + * a type with the same name as in typePtr, it is replaced with the + * new type. + * + *-------------------------------------------------------------- + */ + +void +TclRegisterAuxDataType(typePtr) + AuxDataType *typePtr; /* Information about object type; + * storage must be statically + * allocated (must live forever). */ +{ + register Tcl_HashEntry *hPtr; + int new; + + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); + } + + /* + * If there's already a type with the given name, remove it. + */ + + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); + if (hPtr != (Tcl_HashEntry *) NULL) { + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Now insert the new object type. + */ + + hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new); + if (new) { + Tcl_SetHashValue(hPtr, typePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAuxDataType -- + * + * This procedure looks up an Auxdata type by name. + * + * Results: + * If an AuxData type with name matching "typeName" is found, a pointer + * to its AuxDataType structure is returned; otherwise, NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +AuxDataType * +TclGetAuxDataType(typeName) + char *typeName; /* Name of AuxData type to look up. */ +{ + register Tcl_HashEntry *hPtr; + AuxDataType *typePtr = NULL; + + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); + } + + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); + if (hPtr != (Tcl_HashEntry *) NULL) { + typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); + } + + return typePtr; +} + +/* + *-------------------------------------------------------------- + * + * TclInitAuxDataTypeTable -- + * + * This procedure is invoked to perform once-only initialization of + * the AuxData type table. It also registers the AuxData types defined in + * this file. + * + * Results: + * None. + * + * Side effects: + * Initializes the table of defined AuxData types "auxDataTypeTable" with + * builtin AuxData types defined in this file. + * + *-------------------------------------------------------------- + */ + +void +TclInitAuxDataTypeTable() +{ + auxDataTypeTableInitialized = 1; + + Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); + TclRegisterAuxDataType(&tclForeachInfoType); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeAuxDataTypeTable -- + * + * This procedure is called by Tcl_Finalize after all exit handlers + * have been run to free up storage associated with the table of AuxData + * types. + * + * Results: + * None. + * + * Side effects: + * Deletes all entries in the hash table of AuxData types, "auxDataTypeTable". + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeAuxDataTypeTable() +{ + if (auxDataTypeTableInitialized) { + Tcl_DeleteHashTable(&auxDataTypeTable); + auxDataTypeTableInitialized = 0; + } +} diff --git a/tcl/generic/tclCompile.h b/tcl/generic/tclCompile.h new file mode 100644 index 00000000000..20a0f0fc17b --- /dev/null +++ b/tcl/generic/tclCompile.h @@ -0,0 +1,1054 @@ +/* + * tclCompile.h -- + * + * 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. + * + * RCS: @(#) $Id$ + */ + +#ifndef _TCLCOMPILATION +#define _TCLCOMPILATION 1 + +#ifndef _TCLINT +#include "tclInt.h" +#endif /* _TCLINT */ + +#ifdef BUILD_tcl +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT +#endif + +/* + *------------------------------------------------------------------------ + * Variables related to compilation. These are used in tclCompile.c, + * tclExecute.c, tclBasic.c, and their clients. + *------------------------------------------------------------------------ + */ + +/* + * Variable that denotes the command name Tcl object type. Objects of this + * type cache the Command pointer that results from looking up command names + * in the command hashtable. + */ + +extern Tcl_ObjType tclCmdNameType; + +/* + * Variable that controls whether compilation tracing is enabled and, if so, + * what level of tracing is desired: + * 0: no compilation tracing + * 1: summarize compilation of top level cmds and proc bodies + * 2: display all instructions of each ByteCode compiled + * This variable is linked to the Tcl variable "tcl_traceCompile". + */ + +extern int tclTraceCompile; + +/* + * Variable that controls whether execution tracing is enabled and, if so, + * what level of tracing is desired: + * 0: no execution tracing + * 1: trace invocations of Tcl procs only + * 2: trace invocations of all (not compiled away) commands + * 3: display each instruction executed + * This variable is linked to the Tcl variable "tcl_traceExec". + */ + +extern int tclTraceExec; + +/* + * The number of bytecode compilations and various other compilation-related + * statistics. The tclByteCodeCount and tclSourceCount arrays are used to + * hold the count of ByteCodes and sources whose sizes fall into various + * binary decades; e.g., tclByteCodeCount[5] is a count of the ByteCodes + * with size larger than 2**4 and less than or equal to 2**5. + */ + +#ifdef TCL_COMPILE_STATS +extern long tclNumCompilations; +extern double tclTotalSourceBytes; +extern double tclTotalCodeBytes; + +extern double tclTotalInstBytes; +extern double tclTotalObjBytes; +extern double tclTotalExceptBytes; +extern double tclTotalAuxBytes; +extern double tclTotalCmdMapBytes; + +extern double tclCurrentSourceBytes; +extern double tclCurrentCodeBytes; + +extern int tclSourceCount[32]; +extern int tclByteCodeCount[32]; +#endif /* TCL_COMPILE_STATS */ + +/* + *------------------------------------------------------------------------ + * Data structures related to compilation. + *------------------------------------------------------------------------ + */ + +/* + * The structure used to implement Tcl "exceptions" (exceptional returns): + * for example, those generated in loops by the break and continue commands, + * and those generated by scripts and caught by the catch command. This + * ExceptionRange structure describes a range of code (e.g., a loop body), + * the kind of exceptions (e.g., a break or continue) that might occur, and + * the PC offsets to jump to if a matching exception does occur. Exception + * ranges can nest so this structure includes a nesting level that is used + * at runtime to find the closest exception range surrounding a PC. For + * example, when a break command is executed, the ExceptionRange structure + * for the most deeply nested loop, if any, is found and used. These + * structures are also generated for the "next" subcommands of for loops + * since a break there terminates the for command. This means a for command + * actually generates two LoopInfo structures. + */ + +typedef enum { + LOOP_EXCEPTION_RANGE, /* Code range is part of a loop command. + * break and continue "exceptions" cause + * jumps to appropriate PC offsets. */ + CATCH_EXCEPTION_RANGE /* Code range is controlled by a catch + * command. Errors in the range cause a + * jump to a particular PC offset. */ +} ExceptionRangeType; + +typedef struct ExceptionRange { + ExceptionRangeType type; /* The kind of ExceptionRange. */ + int nestingLevel; /* Static depth of the exception range. + * Used to find the most deeply-nested + * range surrounding a PC at runtime. */ + int codeOffset; /* Offset of the first instruction byte of + * the code range. */ + int numCodeBytes; /* Number of bytes in the code range. */ + int breakOffset; /* If a LOOP_EXCEPTION_RANGE, the target + * PC offset for a break command in the + * range. */ + int continueOffset; /* If a LOOP_EXCEPTION_RANGE and not -1, + * the target PC offset for a continue + * command in the code range. Otherwise, + * ignore this range when processing a + * continue command. */ + int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC + * offset for an "exception" in range. */ +} ExceptionRange; + +/* + * Structure used to map between instruction pc and source locations. It + * defines for each compiled Tcl command its code's starting offset and + * its source's starting offset and length. Note that the code offset + * increases monotonically: that is, the table is sorted in code offset + * order. The source offset is not monotonic. + */ + +typedef struct CmdLocation { + int codeOffset; /* Offset of first byte of command code. */ + int numCodeBytes; /* Number of bytes for command's code. */ + int srcOffset; /* Offset of first char of the command. */ + int numSrcChars; /* Number of command source chars. */ +} CmdLocation; + +/* + * CompileProcs need the ability to record information during compilation + * that can be used by bytecode instructions during execution. The AuxData + * structure provides this "auxiliary data" mechanism. An arbitrary number + * of these structures can be stored in the ByteCode record (during + * compilation they are stored in a CompileEnv structure). Each AuxData + * record holds one word of client-specified data (often a pointer) and is + * given an index that instructions can later use to look up the structure + * and its data. + * + * The following definitions declare the types of procedures that are called + * to duplicate or free this auxiliary data when the containing ByteCode + * objects are duplicated and freed. Pointers to these procedures are kept + * in the AuxData structure. + */ + +typedef ClientData (AuxDataDupProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData)); + +/* + * We define a separate AuxDataType struct to hold type-related information + * for the AuxData structure. This separation makes it possible for clients + * outside of the TCL core to manipulate (in a limited fashion!) AuxData; + * for example, it makes it possible to pickle and unpickle AuxData structs. + */ + +typedef struct AuxDataType { + char *name; /* the name of the type. Types can be + * registered and found by name */ + AuxDataDupProc *dupProc; /* Callback procedure to invoke when the + * aux data is duplicated (e.g., when the + * ByteCode structure containing the aux + * data is duplicated). NULL means just + * copy the source clientData bits; no + * proc need be called. */ + AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the + * aux data is freed. NULL means no + * proc need be called. */ +} AuxDataType; + +/* + * The definition of the AuxData structure that holds information created + * during compilation by CompileProcs and used by instructions during + * execution. + */ + +typedef struct AuxData { + AuxDataType *type; /* pointer to the AuxData type associated with + * this ClientData. */ + ClientData clientData; /* The compilation data itself. */ +} AuxData; + +/* + * Structure defining the compilation environment. After compilation, fields + * describing bytecode instructions are copied out into the more compact + * ByteCode structure defined below. + */ + +#define COMPILEENV_INIT_CODE_BYTES 250 +#define COMPILEENV_INIT_NUM_OBJECTS 40 +#define COMPILEENV_INIT_EXCEPT_RANGES 5 +#define COMPILEENV_INIT_CMD_MAP_SIZE 40 +#define COMPILEENV_INIT_AUX_DATA_SIZE 5 + +typedef struct CompileEnv { + Interp *iPtr; /* Interpreter containing the code being + * compiled. Commands and their compile + * procs are specific to an interpreter so + * the code emitted will depend on the + * interpreter. */ + char *source; /* The source string being compiled by + * SetByteCodeFromAny. This pointer is not + * owned by the CompileEnv and must not be + * freed or changed by it. */ + Proc *procPtr; /* If a procedure is being compiled, a + * pointer to its Proc structure; otherwise + * NULL. Used to compile local variables. + * Set from information provided by + * ObjInterpProc in tclProc.c. */ + int numCommands; /* Number of commands compiled. */ + int excRangeDepth; /* Current exception range nesting level; + * -1 if not in any range currently. */ + int maxExcRangeDepth; /* Max nesting level of exception ranges; + * -1 if no ranges have been compiled. */ + int maxStackDepth; /* Maximum number of stack elements needed + * to execute the code. Set by compilation + * procedures before returning. */ + Tcl_HashTable objTable; /* Contains all Tcl objects referenced by + * the compiled code. Indexed by the string + * representations of the objects. Used to + * avoid creating duplicate objects. */ + int pushSimpleWords; /* Set 1 by callers of compilation routines + * if they should emit instructions to push + * "simple" command words (those that are + * just a sequence of characters). If 0, the + * callers are responsible for compiling + * simple words. */ + int wordIsSimple; /* Set 1 by compilation procedures before + * returning if the previous command word + * was just a sequence of characters, + * otherwise 0. Used to help determine the + * command being compiled. */ + int numSimpleWordChars; /* If wordIsSimple is 1 then the number of + * characters in the simple word, else 0. */ + int exprIsJustVarRef; /* Set 1 if the expression last compiled by + * TclCompileExpr consisted of just a + * variable reference as in the expression + * of "if $b then...". Otherwise 0. Used + * to implement expr's 2 level substitution + * semantics properly. */ + int exprIsComparison; /* Set 1 if the top-level operator in the + * expression last compiled is a comparison. + * Otherwise 0. If 1, since the operands + * might be strings, the expr is compiled + * out-of-line to implement expr's 2 level + * substitution semantics properly. */ + int termOffset; /* Offset of character just after the last + * one compiled. Set by compilation + * procedures before returning. */ + unsigned char *codeStart; /* Points to the first byte of the code. */ + unsigned char *codeNext; /* Points to next code array byte to use. */ + unsigned char *codeEnd; /* Points just after the last allocated + * code array byte. */ + int mallocedCodeArray; /* Set 1 if code array was expanded + * and codeStart points into the heap.*/ + Tcl_Obj **objArrayPtr; /* Points to start of object array. */ + int objArrayNext; /* Index of next free object array entry. */ + int objArrayEnd; /* Index just after last obj array entry. */ + int mallocedObjArray; /* 1 if object array was expanded and + * objArray points into the heap, else 0. */ + ExceptionRange *excRangeArrayPtr; + /* Points to start of the ExceptionRange + * array. */ + int excRangeArrayNext; /* Next free ExceptionRange array index. + * excRangeArrayNext is the number of ranges + * and (excRangeArrayNext-1) is the index of + * the current range's array entry. */ + int excRangeArrayEnd; /* Index after the last ExceptionRange + * array entry. */ + int mallocedExcRangeArray; /* 1 if ExceptionRange array was expanded + * and excRangeArrayPtr points in heap, + * else 0. */ + CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. + * numCommands is the index of the next + * entry to use; (numCommands-1) is the + * entry index for the last command. */ + int cmdMapEnd; /* Index after last CmdLocation entry. */ + int mallocedCmdMap; /* 1 if command map array was expanded and + * cmdMapPtr points in the heap, else 0. */ + AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ + int auxDataArrayNext; /* Next free compile aux data array index. + * auxDataArrayNext is the number of aux + * data items and (auxDataArrayNext-1) is + * index of current aux data array entry. */ + int auxDataArrayEnd; /* Index after last aux data array entry. */ + int mallocedAuxDataArray; /* 1 if aux data array was expanded and + * auxDataArrayPtr points in heap else 0. */ + unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; + /* Initial storage for code. */ + Tcl_Obj *staticObjArraySpace[COMPILEENV_INIT_NUM_OBJECTS]; + /* Initial storage for object array. */ + ExceptionRange staticExcRangeArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; + /* Initial ExceptionRange array storage. */ + CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; + /* Initial storage for cmd location map. */ + AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; + /* Initial storage for aux data array. */ +} CompileEnv; + +/* + * The structure defining the bytecode instructions resulting from compiling + * a Tcl script. Note that this structure is variable length: a single heap + * object is allocated to hold the ByteCode structure immediately followed + * by the code bytes, the object array, the ExceptionRange array, the + * CmdLocation map, and the compilation AuxData array. + */ + +/* + * A PRECOMPILED bytecode struct is one that was generated from a compiled + * image rather than implicitly compiled from source + */ +#define TCL_BYTECODE_PRECOMPILED 0x0001 + +typedef struct ByteCode { + Interp *iPtr; /* Interpreter containing the code being + * compiled. Commands and their compile + * procs are specific to an interpreter so + * the code emitted will depend on the + * interpreter. */ + int compileEpoch; /* Value of iPtr->compileEpoch when this + * ByteCode was compiled. Used to invalidate + * code when, e.g., commands with compile + * procs are redefined. */ + Namespace *nsPtr; /* Namespace context in which this code + * was compiled. If the code is executed + * if a different namespace, it must be + * recompiled. */ + int nsEpoch; /* Value of nsPtr->resolverEpoch when this + * ByteCode was compiled. Used to invalidate + * code when new namespace resolution rules + * are put into effect. */ + int refCount; /* Reference count: set 1 when created + * plus 1 for each execution of the code + * currently active. This structure can be + * freed when refCount becomes zero. */ + unsigned int flags; /* flags describing state for the codebyte. + * this variable holds ORed values from the + * TCL_BYTECODE_ masks defined above */ + char *source; /* The source string from which this + * ByteCode was compiled. Note that this + * pointer is not owned by the ByteCode and + * must not be freed or modified by it. */ + Proc *procPtr; /* If the ByteCode was compiled from a + * procedure body, this is a pointer to its + * Proc structure; otherwise NULL. This + * pointer is also not owned by the ByteCode + * and must not be freed by it. Used for + * debugging. */ + size_t totalSize; /* Total number of bytes required for this + * ByteCode structure including the storage + * for Tcl objects in its object array. */ + int numCommands; /* Number of commands compiled. */ + int numSrcChars; /* Number of source chars compiled. */ + int numCodeBytes; /* Number of code bytes. */ + int numObjects; /* Number of Tcl objects in object array. */ + int numExcRanges; /* Number of ExceptionRange array elems. */ + int numAuxDataItems; /* Number of AuxData items. */ + int numCmdLocBytes; /* Number of bytes needed for encoded + * command location information. */ + int maxExcRangeDepth; /* Maximum nesting level of ExceptionRanges; + * -1 if no ranges were compiled. */ + int maxStackDepth; /* Maximum number of stack elements needed + * to execute the code. */ + unsigned char *codeStart; /* Points to the first byte of the code. + * This is just after the final ByteCode + * member cmdMapPtr. */ + Tcl_Obj **objArrayPtr; /* Points to the start of the object array. + * This is just after the last code byte. */ + ExceptionRange *excRangeArrayPtr; + /* Points to the start of the ExceptionRange + * array. This is just after the last + * object in the object array. */ + AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data + * array. This is just after the last entry + * in the ExceptionRange array. */ + unsigned char *codeDeltaStart; + /* Points to the first of a sequence of + * bytes that encode the change in the + * starting offset of each command's code. + * If -127<=delta<=127, it is encoded as 1 + * byte, otherwise 0xFF (128) appears and + * the delta is encoded by the next 4 bytes. + * Code deltas are always positive. This + * sequence is just after the last entry in + * the AuxData array. */ + unsigned char *codeLengthStart; + /* Points to the first of a sequence of + * bytes that encode the length of each + * command's code. The encoding is the same + * as for code deltas. Code lengths are + * always positive. This sequence is just + * after the last entry in the code delta + * sequence. */ + unsigned char *srcDeltaStart; + /* Points to the first of a sequence of + * bytes that encode the change in the + * starting offset of each command's source. + * The encoding is the same as for code + * deltas. Source deltas can be negative. + * This sequence is just after the last byte + * in the code length sequence. */ + unsigned char *srcLengthStart; + /* Points to the first of a sequence of + * bytes that encode the length of each + * command's source. The encoding is the + * same as for code deltas. Source lengths + * are always positive. This sequence is + * just after the last byte in the source + * delta sequence. */ +} ByteCode; + +/* + * Opcodes for the Tcl bytecode instructions. These opcodes must correspond + * to the entries in the table of instruction descriptions in tclCompile.c. + * Also, the order and number of the expression opcodes (e.g., INST_LOR) + * must match the entries in the array operatorStrings in tclExecute.c. + */ + +/* Opcodes 0 to 9 */ +#define INST_DONE 0 +#define INST_PUSH1 (INST_DONE + 1) +#define INST_PUSH4 (INST_DONE + 2) +#define INST_POP (INST_DONE + 3) +#define INST_DUP (INST_DONE + 4) +#define INST_CONCAT1 (INST_DONE + 5) +#define INST_INVOKE_STK1 (INST_DONE + 6) +#define INST_INVOKE_STK4 (INST_DONE + 7) +#define INST_EVAL_STK (INST_DONE + 8) +#define INST_EXPR_STK (INST_DONE + 9) + +/* Opcodes 10 to 23 */ +#define INST_LOAD_SCALAR1 (INST_EXPR_STK + 1) +#define INST_LOAD_SCALAR4 (INST_LOAD_SCALAR1 + 1) +#define INST_LOAD_SCALAR_STK (INST_LOAD_SCALAR1 + 2) +#define INST_LOAD_ARRAY1 (INST_LOAD_SCALAR1 + 3) +#define INST_LOAD_ARRAY4 (INST_LOAD_SCALAR1 + 4) +#define INST_LOAD_ARRAY_STK (INST_LOAD_SCALAR1 + 5) +#define INST_LOAD_STK (INST_LOAD_SCALAR1 + 6) +#define INST_STORE_SCALAR1 (INST_LOAD_SCALAR1 + 7) +#define INST_STORE_SCALAR4 (INST_LOAD_SCALAR1 + 8) +#define INST_STORE_SCALAR_STK (INST_LOAD_SCALAR1 + 9) +#define INST_STORE_ARRAY1 (INST_LOAD_SCALAR1 + 10) +#define INST_STORE_ARRAY4 (INST_LOAD_SCALAR1 + 11) +#define INST_STORE_ARRAY_STK (INST_LOAD_SCALAR1 + 12) +#define INST_STORE_STK (INST_LOAD_SCALAR1 + 13) + +/* Opcodes 24 to 33 */ +#define INST_INCR_SCALAR1 (INST_STORE_STK + 1) +#define INST_INCR_SCALAR_STK (INST_INCR_SCALAR1 + 1) +#define INST_INCR_ARRAY1 (INST_INCR_SCALAR1 + 2) +#define INST_INCR_ARRAY_STK (INST_INCR_SCALAR1 + 3) +#define INST_INCR_STK (INST_INCR_SCALAR1 + 4) +#define INST_INCR_SCALAR1_IMM (INST_INCR_SCALAR1 + 5) +#define INST_INCR_SCALAR_STK_IMM (INST_INCR_SCALAR1 + 6) +#define INST_INCR_ARRAY1_IMM (INST_INCR_SCALAR1 + 7) +#define INST_INCR_ARRAY_STK_IMM (INST_INCR_SCALAR1 + 8) +#define INST_INCR_STK_IMM (INST_INCR_SCALAR1 + 9) + +/* Opcodes 34 to 39 */ +#define INST_JUMP1 (INST_INCR_STK_IMM + 1) +#define INST_JUMP4 (INST_JUMP1 + 1) +#define INST_JUMP_TRUE1 (INST_JUMP1 + 2) +#define INST_JUMP_TRUE4 (INST_JUMP1 + 3) +#define INST_JUMP_FALSE1 (INST_JUMP1 + 4) +#define INST_JUMP_FALSE4 (INST_JUMP1 + 5) + +/* Opcodes 40 to 64 */ +#define INST_LOR (INST_JUMP_FALSE4 + 1) +#define INST_LAND (INST_LOR + 1) +#define INST_BITOR (INST_LOR + 2) +#define INST_BITXOR (INST_LOR + 3) +#define INST_BITAND (INST_LOR + 4) +#define INST_EQ (INST_LOR + 5) +#define INST_NEQ (INST_LOR + 6) +#define INST_LT (INST_LOR + 7) +#define INST_GT (INST_LOR + 8) +#define INST_LE (INST_LOR + 9) +#define INST_GE (INST_LOR + 10) +#define INST_LSHIFT (INST_LOR + 11) +#define INST_RSHIFT (INST_LOR + 12) +#define INST_ADD (INST_LOR + 13) +#define INST_SUB (INST_LOR + 14) +#define INST_MULT (INST_LOR + 15) +#define INST_DIV (INST_LOR + 16) +#define INST_MOD (INST_LOR + 17) +#define INST_UPLUS (INST_LOR + 18) +#define INST_UMINUS (INST_LOR + 19) +#define INST_BITNOT (INST_LOR + 20) +#define INST_LNOT (INST_LOR + 21) +#define INST_CALL_BUILTIN_FUNC1 (INST_LOR + 22) +#define INST_CALL_FUNC1 (INST_LOR + 23) +#define INST_TRY_CVT_TO_NUMERIC (INST_LOR + 24) + +/* Opcodes 65 to 66 */ +#define INST_BREAK (INST_TRY_CVT_TO_NUMERIC + 1) +#define INST_CONTINUE (INST_BREAK + 1) + +/* Opcodes 67 to 68 */ +#define INST_FOREACH_START4 (INST_CONTINUE + 1) +#define INST_FOREACH_STEP4 (INST_FOREACH_START4 + 1) + +/* Opcodes 69 to 72 */ +#define INST_BEGIN_CATCH4 (INST_FOREACH_STEP4 + 1) +#define INST_END_CATCH (INST_BEGIN_CATCH4 + 1) +#define INST_PUSH_RESULT (INST_BEGIN_CATCH4 + 2) +#define INST_PUSH_RETURN_CODE (INST_BEGIN_CATCH4 + 3) + +/* The last opcode */ +#define LAST_INST_OPCODE INST_PUSH_RETURN_CODE + +/* + * Table describing the Tcl bytecode instructions: their name (for + * displaying code), total number of code bytes required (including + * operand bytes), and a description of the type of each operand. + * These operand types include signed and unsigned integers of length + * one and four bytes. The unsigned integers are used for indexes or + * for, e.g., the count of objects to push in a "push" instruction. + */ + +#define MAX_INSTRUCTION_OPERANDS 2 + +typedef enum InstOperandType { + OPERAND_NONE, + OPERAND_INT1, /* One byte signed integer. */ + OPERAND_INT4, /* Four byte signed integer. */ + OPERAND_UINT1, /* One byte unsigned integer. */ + OPERAND_UINT4 /* Four byte unsigned integer. */ +} InstOperandType; + +typedef struct InstructionDesc { + char *name; /* Name of instruction. */ + int numBytes; /* Total number of bytes for instruction. */ + int numOperands; /* Number of operands. */ + InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; + /* The type of each operand. */ +} InstructionDesc; + +extern InstructionDesc instructionTable[]; + +/* + * Definitions of the values of the INST_CALL_BUILTIN_FUNC instruction's + * operand byte. Each value denotes a builtin Tcl math function. These + * values must correspond to the entries in the builtinFuncTable array + * below and to the values stored in the tclInt.h MathFunc structure's + * builtinFuncIndex field. + */ + +#define BUILTIN_FUNC_ACOS 0 +#define BUILTIN_FUNC_ASIN 1 +#define BUILTIN_FUNC_ATAN 2 +#define BUILTIN_FUNC_ATAN2 3 +#define BUILTIN_FUNC_CEIL 4 +#define BUILTIN_FUNC_COS 5 +#define BUILTIN_FUNC_COSH 6 +#define BUILTIN_FUNC_EXP 7 +#define BUILTIN_FUNC_FLOOR 8 +#define BUILTIN_FUNC_FMOD 9 +#define BUILTIN_FUNC_HYPOT 10 +#define BUILTIN_FUNC_LOG 11 +#define BUILTIN_FUNC_LOG10 12 +#define BUILTIN_FUNC_POW 13 +#define BUILTIN_FUNC_SIN 14 +#define BUILTIN_FUNC_SINH 15 +#define BUILTIN_FUNC_SQRT 16 +#define BUILTIN_FUNC_TAN 17 +#define BUILTIN_FUNC_TANH 18 +#define BUILTIN_FUNC_ABS 19 +#define BUILTIN_FUNC_DOUBLE 20 +#define BUILTIN_FUNC_INT 21 +#define BUILTIN_FUNC_RAND 22 +#define BUILTIN_FUNC_ROUND 23 +#define BUILTIN_FUNC_SRAND 24 + +#define LAST_BUILTIN_FUNC BUILTIN_FUNC_SRAND + +/* + * Table describing the built-in math functions. Entries in this table are + * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's + * operand byte. + */ + +typedef int (CallBuiltinFuncProc) _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); + +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. */ + CallBuiltinFuncProc *proc; /* Procedure implementing this function. */ + ClientData clientData; /* Additional argument to pass to the + * function when invoking it. */ +} BuiltinFunc; + +extern BuiltinFunc builtinFuncTable[]; + +/* + * The structure used to hold information about the start and end of each + * argument word in a command. + */ + +#define ARGINFO_INIT_ENTRIES 5 + +typedef struct ArgInfo { + int numArgs; /* Number of argument words in command. */ + char **startArray; /* Array of pointers to the first character + * of each argument word. */ + char **endArray; /* Array of pointers to the last character + * of each argument word. */ + int allocArgs; /* Number of array entries currently + * allocated. */ + int mallocedArrays; /* 1 if the arrays were expanded and + * wordStartArray/wordEndArray point into + * the heap, else 0. */ + char *staticStartSpace[ARGINFO_INIT_ENTRIES]; + /* Initial storage for word start array. */ + char *staticEndSpace[ARGINFO_INIT_ENTRIES]; + /* Initial storage for word end array. */ +} ArgInfo; + +/* + * Compilation of some Tcl constructs such as if commands and the logical or + * (||) and logical and (&&) operators in expressions requires the + * generation of forward jumps. Since the PC target of these jumps isn't + * known when the jumps are emitted, we record the offset of each jump in an + * array of JumpFixup structures. There is one array for each sequence of + * jumps to one target PC. When we learn the target PC, we update the jumps + * with the correct distance. Also, if the distance is too great (> 127 + * bytes), we replace the single-byte jump with a four byte jump + * instruction, move the instructions after the jump down, and update the + * code offsets for any commands between the jump and the target. + */ + +typedef enum { + TCL_UNCONDITIONAL_JUMP, + TCL_TRUE_JUMP, + TCL_FALSE_JUMP +} TclJumpType; + +typedef struct JumpFixup { + TclJumpType jumpType; /* Indicates the kind of jump. */ + int codeOffset; /* Offset of the first byte of the one-byte + * forward jump's code. */ + int cmdIndex; /* Index of the first command after the one + * for which the jump was emitted. Used to + * update the code offsets for subsequent + * commands if the two-byte jump at jumpPc + * must be replaced with a five-byte one. */ + int excRangeIndex; /* Index of the first range entry in the + * ExceptionRange array after the current + * one. This field is used to adjust the + * code offsets in subsequent ExceptionRange + * records when a jump is grown from 2 bytes + * to 5 bytes. */ +} JumpFixup; + +#define JUMPFIXUP_INIT_ENTRIES 10 + +typedef struct JumpFixupArray { + JumpFixup *fixup; /* Points to start of jump fixup array. */ + int next; /* Index of next free array entry. */ + int end; /* Index of last usable entry in array. */ + int mallocedArray; /* 1 if array was expanded and fixups points + * into the heap, else 0. */ + JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; + /* Initial storage for jump fixup array. */ +} JumpFixupArray; + +/* + * The structure describing one variable list of a foreach command. Note + * that only foreach commands inside procedure bodies are compiled inline so + * a ForeachVarList structure always describes local variables. Furthermore, + * only scalar variables are supported for inline-compiled foreach loops. + */ + +typedef struct ForeachVarList { + int numVars; /* The number of variables in the list. */ + int varIndexes[1]; /* An array of the indexes ("slot numbers") + * for each variable in the procedure's + * array of local variables. Only scalar + * variables are supported. The actual + * size of this field will be large enough + * to numVars indexes. THIS MUST BE THE + * LAST FIELD IN THE STRUCTURE! */ +} ForeachVarList; + +/* + * Structure used to hold information about a foreach command that is needed + * during program execution. These structures are stored in CompileEnv and + * ByteCode structures as auxiliary data. + */ + +typedef struct ForeachInfo { + int numLists; /* The number of both the variable and value + * lists of the foreach command. */ + int firstListTmp; /* The slot number of the first temporary + * variable holding the lists themselves. */ + int loopIterNumTmp; /* The slot number of the temp var holding + * the count of times the loop body has been + * executed. This is used to determine which + * list element to assign each loop var. */ + ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList + * structures describing each var list. The + * actual size of this field will be large + * enough to numVars indexes. THIS MUST BE + * THE LAST FIELD IN THE STRUCTURE! */ +} ForeachInfo; + +/* + * Structure containing a cached pointer to a command that is the result + * of resolving the command's name in some namespace. It is the internal + * representation for a cmdName object. It contains the pointer along + * with some information that is used to check the pointer's validity. + */ + +typedef struct ResolvedCmdName { + Command *cmdPtr; /* A cached Command pointer. */ + Namespace *refNsPtr; /* Points to the namespace containing the + * reference (not the namespace that + * contains the referenced command). */ + long refNsId; /* refNsPtr's unique namespace id. Used to + * verify that refNsPtr is still valid + * (e.g., it's possible that the cmd's + * containing namespace was deleted and a + * new one created at the same address). */ + int refNsCmdEpoch; /* Value of the referencing namespace's + * cmdRefEpoch when the pointer was cached. + * Before using the cached pointer, we check + * if the namespace's epoch was incremented; + * if so, this cached pointer is invalid. */ + int cmdEpoch; /* Value of the command's cmdEpoch when this + * pointer was cached. Before using the + * cached pointer, we check if the cmd's + * epoch was incremented; if so, the cmd was + * renamed, deleted, hidden, or exposed, and + * so the pointer is invalid. */ + int refCount; /* Reference count: 1 for each cmdName + * object that has a pointer to this + * ResolvedCmdName structure as its internal + * rep. This structure can be freed when + * refCount becomes zero. */ +} ResolvedCmdName; + +/* + *---------------------------------------------------------------- + * Procedures shared among Tcl bytecode compilation and execution + * modules but not used outside: + *---------------------------------------------------------------- + */ + +EXTERN void TclCleanupByteCode _ANSI_ARGS_((ByteCode *codePtr)); +EXTERN int TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int flags, + CompileEnv *envPtr)); +EXTERN int TclCompileQuotes _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int termChar, + int flags, CompileEnv *envPtr)); +EXTERN int TclCompileString _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int flags, + CompileEnv *envPtr)); +EXTERN int TclCompileDollarVar _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int flags, + CompileEnv *envPtr)); +EXTERN int TclCreateAuxData _ANSI_ARGS_((ClientData clientData, + AuxDataType *typePtr, CompileEnv *envPtr)); +EXTERN ExecEnv * TclCreateExecEnv _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void TclDeleteExecEnv _ANSI_ARGS_((ExecEnv *eePtr)); +EXTERN void TclEmitForwardJump _ANSI_ARGS_((CompileEnv *envPtr, + TclJumpType jumpType, JumpFixup *jumpFixupPtr)); +EXTERN AuxDataType *TclGetAuxDataType _ANSI_ARGS_((char *typeName)); +EXTERN ExceptionRange * TclGetExceptionRangeForPc _ANSI_ARGS_(( + unsigned char *pc, int catchOnly, + ByteCode* codePtr)); +EXTERN InstructionDesc * TclGetInstructionTable _ANSI_ARGS_(()); +EXTERN int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, + ByteCode *codePtr)); +EXTERN void TclExpandCodeArray _ANSI_ARGS_(( + CompileEnv *envPtr)); +EXTERN void TclExpandJumpFixupArray _ANSI_ARGS_(( + JumpFixupArray *fixupArrayPtr)); +EXTERN void TclFinalizeAuxDataTypeTable _ANSI_ARGS_((void)); +EXTERN int TclFixupForwardJump _ANSI_ARGS_(( + CompileEnv *envPtr, JumpFixup *jumpFixupPtr, + int jumpDist, int distThreshold)); +EXTERN void TclFreeCompileEnv _ANSI_ARGS_((CompileEnv *envPtr)); +EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_(( + JumpFixupArray *fixupArrayPtr)); +EXTERN void TclInitAuxDataTypeTable _ANSI_ARGS_((void)); +EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr, + CompileEnv *envPtr)); +EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, + CompileEnv *envPtr, char *string)); +EXTERN void TclInitJumpFixupArray _ANSI_ARGS_(( + JumpFixupArray *fixupArrayPtr)); +#ifdef TCL_COMPILE_STATS +EXTERN int TclLog2 _ANSI_ARGS_((int value)); +#endif /*TCL_COMPILE_STATS*/ +EXTERN int TclObjIndexForString _ANSI_ARGS_((char *start, + int length, int allocStrRep, int inHeap, + CompileEnv *envPtr)); +EXTERN int TclPrintInstruction _ANSI_ARGS_((ByteCode* codePtr, + unsigned char *pc)); +EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, + char *string, int maxChars)); +EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); + +/* + *---------------------------------------------------------------- + * Macros used by Tcl bytecode compilation and execution modules + * inside the Tcl core but not used outside. + *---------------------------------------------------------------- + */ + +/* + * Macros to ensure there is enough room in a CompileEnv's code array. + * The ANSI C "prototypes" for these macros are: + * + * EXTERN void TclEnsureCodeSpace1 _ANSI_ARGS_((CompileEnv *envPtr)); + * EXTERN void TclEnsureCodeSpace _ANSI_ARGS_((int nBytes, + * CompileEnv *envPtr)); + */ + +#define TclEnsureCodeSpace1(envPtr) \ + if ((envPtr)->codeNext == (envPtr)->codeEnd) \ + TclExpandCodeArray(envPtr) + +#define TclEnsureCodeSpace(nBytes, envPtr) \ + if (((envPtr)->codeNext + nBytes) > (envPtr)->codeEnd) \ + TclExpandCodeArray(envPtr) + +/* + * Macro to emit an opcode byte into a CompileEnv's code array. + * The ANSI C "prototype" for this macro is: + * + * EXTERN void TclEmitOpcode _ANSI_ARGS_((unsigned char op, + * CompileEnv *envPtr)); + */ + +#define TclEmitOpcode(op, envPtr) \ + TclEnsureCodeSpace1(envPtr); \ + *(envPtr)->codeNext++ = (unsigned char) (op) + +/* + * Macros to emit a (signed or unsigned) int operand. The two variants + * depend on the number of bytes needed for the int. Four byte integers + * are stored in "big-endian" order with the high order byte stored at + * the lowest address. The ANSI C "prototypes" for these macros are: + * + * EXTERN void TclEmitInt1 _ANSI_ARGS_((int i, CompileEnv *envPtr)); + * EXTERN void TclEmitInt4 _ANSI_ARGS_((int i, CompileEnv *envPtr)); + */ + +#define TclEmitInt1(i, envPtr) \ + TclEnsureCodeSpace(1, (envPtr)); \ + *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)) + +#define TclEmitInt4(i, envPtr) \ + TclEnsureCodeSpace(4, (envPtr)); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 24); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 16); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 8); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) ) + +/* + * Macros to emit an instruction with signed or unsigned int operands. + * The ANSI C "prototypes" for these macros are: + * + * EXTERN void TclEmitInstInt1 _ANSI_ARGS_((unsigned char op, int i, + * CompileEnv *envPtr)); + * EXTERN void TclEmitInstInt4 _ANSI_ARGS_((unsigned char op, int i, + * CompileEnv *envPtr)); + * EXTERN void TclEmitInstUInt1 _ANSI_ARGS_((unsigned char op, + * unsigned int i, CompileEnv *envPtr)); + * EXTERN void TclEmitInstUInt4 _ANSI_ARGS_((unsigned char op, + * unsigned int i, CompileEnv *envPtr)); + */ + +#define TclEmitInstInt1(op, i, envPtr) \ + TclEnsureCodeSpace(2, (envPtr)); \ + *(envPtr)->codeNext++ = (unsigned char) (op); \ + *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)) + +#define TclEmitInstInt4(op, i, envPtr) \ + TclEnsureCodeSpace(5, (envPtr)); \ + *(envPtr)->codeNext++ = (unsigned char) (op); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 24); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 16); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 8); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) ) + +#define TclEmitInstUInt1(op, i, envPtr) \ + TclEmitInstInt1((op), (i), (envPtr)) + +#define TclEmitInstUInt4(op, i, envPtr) \ + TclEmitInstInt4((op), (i), (envPtr)) + +/* + * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the + * object's one or four byte array index into the CompileEnv's code + * array. These support, respectively, a maximum of 256 (2**8) and 2**32 + * objects in a CompileEnv. The ANSI C "prototype" for this macro is: + * + * EXTERN void TclEmitPush _ANSI_ARGS_((int objIndex, CompileEnv *envPtr)); + */ + +#define TclEmitPush(objIndex, envPtr) \ + if ((objIndex) <= 255) { \ + TclEmitInstUInt1(INST_PUSH1, (objIndex), (envPtr)); \ + } else { \ + TclEmitInstUInt4(INST_PUSH4, (objIndex), (envPtr)); \ + } + +/* + * Macros to update a (signed or unsigned) integer starting at a pointer. + * The two variants depend on the number of bytes. The ANSI C "prototypes" + * for these macros are: + * + * EXTERN void TclStoreInt1AtPtr _ANSI_ARGS_((int i, unsigned char *p)); + * EXTERN void TclStoreInt4AtPtr _ANSI_ARGS_((int i, unsigned char *p)); + */ + +#define TclStoreInt1AtPtr(i, p) \ + *(p) = (unsigned char) ((unsigned int) (i)) + +#define TclStoreInt4AtPtr(i, p) \ + *(p) = (unsigned char) ((unsigned int) (i) >> 24); \ + *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \ + *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \ + *(p+3) = (unsigned char) ((unsigned int) (i) ) + +/* + * Macros to update instructions at a particular pc with a new op code + * and a (signed or unsigned) int operand. The ANSI C "prototypes" for + * these macros are: + * + * EXTERN void TclUpdateInstInt1AtPc _ANSI_ARGS_((unsigned char op, int i, + * unsigned char *pc)); + * EXTERN void TclUpdateInstInt4AtPc _ANSI_ARGS_((unsigned char op, int i, + * unsigned char *pc)); + */ + +#define TclUpdateInstInt1AtPc(op, i, pc) \ + *(pc) = (unsigned char) (op); \ + TclStoreInt1AtPtr((i), ((pc)+1)) + +#define TclUpdateInstInt4AtPc(op, i, pc) \ + *(pc) = (unsigned char) (op); \ + TclStoreInt4AtPtr((i), ((pc)+1)) + +/* + * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int + * (GET_UINT{1,2}) from a pointer. There are two variants for each + * return type that depend on the number of bytes fetched. + * The ANSI C "prototypes" for these macros are: + * + * EXTERN int TclGetInt1AtPtr _ANSI_ARGS_((unsigned char *p)); + * EXTERN int TclGetInt4AtPtr _ANSI_ARGS_((unsigned char *p)); + * EXTERN unsigned int TclGetUInt1AtPtr _ANSI_ARGS_((unsigned char *p)); + * EXTERN unsigned int TclGetUInt4AtPtr _ANSI_ARGS_((unsigned char *p)); + */ + +/* + * The TclGetInt1AtPtr macro is tricky because we want to do sign + * extension on the 1-byte value. Unfortunately the "char" type isn't + * signed on all platforms so sign-extension doesn't always happen + * automatically. Sometimes we can explicitly declare the pointer to be + * signed, but other times we have to explicitly sign-extend the value + * in software. + */ + +#ifndef __CHAR_UNSIGNED__ +# define TclGetInt1AtPtr(p) ((int) *((char *) p)) +#else +# ifdef HAVE_SIGNED_CHAR +# define TclGetInt1AtPtr(p) ((int) *((signed char *) p)) +# else +# define TclGetInt1AtPtr(p) (((int) *((char *) p)) \ + | ((*(p) & 0200) ? (-256) : 0)) +# endif +#endif + +#define TclGetInt4AtPtr(p) (((int) TclGetInt1AtPtr(p) << 24) | \ + (*((p)+1) << 16) | \ + (*((p)+2) << 8) | \ + (*((p)+3))) + +#define TclGetUInt1AtPtr(p) ((unsigned int) *(p)) +#define TclGetUInt4AtPtr(p) ((unsigned int) (*(p) << 24) | \ + (*((p)+1) << 16) | \ + (*((p)+2) << 8) | \ + (*((p)+3))) + +/* + * Macros used to compute the minimum and maximum of two integers. + * The ANSI C "prototypes" for these macros are: + * + * EXTERN int TclMin _ANSI_ARGS_((int i, int j)); + * EXTERN int TclMax _ANSI_ARGS_((int i, int j)); + */ + +#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) +#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) + +/* + * Macro used to compute the offset of the current instruction in the + * bytecode instruction stream. The ANSI C "prototypes" for this macro is: + * + * EXTERN int TclCurrCodeOffset _ANSI_ARGS_((void)); + */ + +#define TclCurrCodeOffset() ((envPtr)->codeNext - (envPtr)->codeStart) + +/* + * Upper bound for legal jump distances. Checked during compilation if + * debugging. + */ + +#define MAX_JUMP_DIST 5000 + +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLIMPORT + +#endif /* _TCLCOMPILATION */ diff --git a/tcl/generic/tclDate.c b/tcl/generic/tclDate.c new file mode 100644 index 00000000000..9d91c2b4719 --- /dev/null +++ b/tcl/generic/tclDate.c @@ -0,0 +1,1638 @@ +/* + * tclDate.c -- + * + * This file is generated from a yacc grammar defined in + * the file tclGetDate.y. It should not be edited directly. + * + * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. + * Copyright (c) 1995-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +#ifdef MAC_TCL +# define EPOCH 1904 +# define START_OF_TIME 1904 +# define END_OF_TIME 2039 +#else +# define EPOCH 1970 +# define START_OF_TIME 1902 +# define END_OF_TIME 2037 +#endif + +/* + * The offset of tm_year of struct tm returned by localtime, gmtime, etc. + * I don't know how universal this is; K&R II, the NetBSD manpages, and + * ../compat/strftime.c all agree that tm_year is the year-1900. However, + * some systems may have a different value. This #define should be the + * same as in ../compat/strftime.c. + */ +#define TM_YEAR_BASE 1900 + +#define HOUR(x) ((int) (60 * x)) +#define SECSPERDAY (24L * 60L * 60L) + + +/* + * An entry in the lexical lookup table. + */ +typedef struct _TABLE { + char *name; + int type; + time_t value; +} TABLE; + + +/* + * Daylight-savings mode: on, off, or not yet known. + */ +typedef enum _DSTMODE { + DSTon, DSToff, DSTmaybe +} DSTMODE; + +/* + * Meridian: am, pm, or 24-hour style. + */ +typedef enum _MERIDIAN { + MERam, MERpm, MER24 +} MERIDIAN; + + +/* + * Global variables. We could get rid of most of these by using a good + * union as the yacc stack. (This routine was originally written before + * yacc had the %union construct.) Maybe someday; right now we only use + * the %union very rarely. + */ +static char *TclDateInput; +static DSTMODE TclDateDSTmode; +static time_t TclDateDayOrdinal; +static time_t TclDateDayNumber; +static int TclDateHaveDate; +static int TclDateHaveDay; +static int TclDateHaveRel; +static int TclDateHaveTime; +static int TclDateHaveZone; +static time_t TclDateTimezone; +static time_t TclDateDay; +static time_t TclDateHour; +static time_t TclDateMinutes; +static time_t TclDateMonth; +static time_t TclDateSeconds; +static time_t TclDateYear; +static MERIDIAN TclDateMeridian; +static time_t TclDateRelMonth; +static time_t TclDateRelSeconds; + + +/* + * Prototypes of internal functions. + */ +static void TclDateerror _ANSI_ARGS_((char *s)); +static time_t ToSeconds _ANSI_ARGS_((time_t Hours, time_t Minutes, + time_t Seconds, MERIDIAN Meridian)); +static int Convert _ANSI_ARGS_((time_t Month, time_t Day, time_t Year, + time_t Hours, time_t Minutes, time_t Seconds, + MERIDIAN Meridia, DSTMODE DSTmode, time_t *TimePtr)); +static time_t DSTcorrect _ANSI_ARGS_((time_t Start, time_t Future)); +static time_t RelativeDate _ANSI_ARGS_((time_t Start, time_t DayOrdinal, + time_t DayNumber)); +static int RelativeMonth _ANSI_ARGS_((time_t Start, time_t RelMonth, + time_t *TimePtr)); +static int LookupWord _ANSI_ARGS_((char *buff)); +static int TclDatelex _ANSI_ARGS_((void)); + +int +TclDateparse _ANSI_ARGS_((void)); +typedef union +#ifdef __cplusplus + YYSTYPE +#endif + { + time_t Number; + enum _MERIDIAN Meridian; +} YYSTYPE; +# define tAGO 257 +# define tDAY 258 +# define tDAYZONE 259 +# define tID 260 +# define tMERIDIAN 261 +# define tMINUTE_UNIT 262 +# define tMONTH 263 +# define tMONTH_UNIT 264 +# define tSEC_UNIT 265 +# define tSNUMBER 266 +# define tUNUMBER 267 +# define tZONE 268 +# define tEPOCH 269 +# define tDST 270 + + + +#ifdef __cplusplus + +#ifndef TclDateerror + void TclDateerror(const char *); +#endif + +#ifndef TclDatelex +#ifdef __EXTERN_C__ + extern "C" { int TclDatelex(void); } +#else + int TclDatelex(void); +#endif +#endif + int TclDateparse(void); + +#endif +#define TclDateclearin TclDatechar = -1 +#define TclDateerrok TclDateerrflag = 0 +extern int TclDatechar; +extern int TclDateerrflag; +YYSTYPE TclDatelval; +YYSTYPE TclDateval; +typedef int TclDatetabelem; +#ifndef YYMAXDEPTH +#define YYMAXDEPTH 150 +#endif +#if YYMAXDEPTH > 0 +int TclDate_TclDates[YYMAXDEPTH], *TclDates = TclDate_TclDates; +YYSTYPE TclDate_TclDatev[YYMAXDEPTH], *TclDatev = TclDate_TclDatev; +#else /* user does initial allocation */ +int *TclDates; +YYSTYPE *TclDatev; +#endif +static int TclDatemaxdepth = YYMAXDEPTH; +# define YYERRCODE 256 + + +/* + * Month and day table. + */ +static TABLE MonthDayTable[] = { + { "january", tMONTH, 1 }, + { "february", tMONTH, 2 }, + { "march", tMONTH, 3 }, + { "april", tMONTH, 4 }, + { "may", tMONTH, 5 }, + { "june", tMONTH, 6 }, + { "july", tMONTH, 7 }, + { "august", tMONTH, 8 }, + { "september", tMONTH, 9 }, + { "sept", tMONTH, 9 }, + { "october", tMONTH, 10 }, + { "november", tMONTH, 11 }, + { "december", tMONTH, 12 }, + { "sunday", tDAY, 0 }, + { "monday", tDAY, 1 }, + { "tuesday", tDAY, 2 }, + { "tues", tDAY, 2 }, + { "wednesday", tDAY, 3 }, + { "wednes", tDAY, 3 }, + { "thursday", tDAY, 4 }, + { "thur", tDAY, 4 }, + { "thurs", tDAY, 4 }, + { "friday", tDAY, 5 }, + { "saturday", tDAY, 6 }, + { NULL } +}; + +/* + * Time units table. + */ +static TABLE UnitsTable[] = { + { "year", tMONTH_UNIT, 12 }, + { "month", tMONTH_UNIT, 1 }, + { "fortnight", tMINUTE_UNIT, 14 * 24 * 60 }, + { "week", tMINUTE_UNIT, 7 * 24 * 60 }, + { "day", tMINUTE_UNIT, 1 * 24 * 60 }, + { "hour", tMINUTE_UNIT, 60 }, + { "minute", tMINUTE_UNIT, 1 }, + { "min", tMINUTE_UNIT, 1 }, + { "second", tSEC_UNIT, 1 }, + { "sec", tSEC_UNIT, 1 }, + { NULL } +}; + +/* + * Assorted relative-time words. + */ +static TABLE OtherTable[] = { + { "tomorrow", tMINUTE_UNIT, 1 * 24 * 60 }, + { "yesterday", tMINUTE_UNIT, -1 * 24 * 60 }, + { "today", tMINUTE_UNIT, 0 }, + { "now", tMINUTE_UNIT, 0 }, + { "last", tUNUMBER, -1 }, + { "this", tMINUTE_UNIT, 0 }, + { "next", tUNUMBER, 2 }, +#if 0 + { "first", tUNUMBER, 1 }, +/* { "second", tUNUMBER, 2 }, */ + { "third", tUNUMBER, 3 }, + { "fourth", tUNUMBER, 4 }, + { "fifth", tUNUMBER, 5 }, + { "sixth", tUNUMBER, 6 }, + { "seventh", tUNUMBER, 7 }, + { "eighth", tUNUMBER, 8 }, + { "ninth", tUNUMBER, 9 }, + { "tenth", tUNUMBER, 10 }, + { "eleventh", tUNUMBER, 11 }, + { "twelfth", tUNUMBER, 12 }, +#endif + { "ago", tAGO, 1 }, + { "epoch", tEPOCH, 0 }, + { NULL } +}; + +/* + * The timezone table. (Note: This table was modified to not use any floating + * point constants to work around an SGI compiler bug). + */ +static TABLE TimezoneTable[] = { + { "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */ + { "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */ + { "utc", tZONE, HOUR( 0) }, + { "wet", tZONE, HOUR( 0) } , /* Western European */ + { "bst", tDAYZONE, HOUR( 0) }, /* British Summer */ + { "wat", tZONE, HOUR( 1) }, /* West Africa */ + { "at", tZONE, HOUR( 2) }, /* Azores */ +#if 0 + /* For completeness. BST is also British Summer, and GST is + * also Guam Standard. */ + { "bst", tZONE, HOUR( 3) }, /* Brazil Standard */ + { "gst", tZONE, HOUR( 3) }, /* Greenland Standard */ +#endif + { "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */ + { "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */ + { "ndt", tDAYZONE, HOUR( 7/2) }, /* Newfoundland Daylight */ + { "ast", tZONE, HOUR( 4) }, /* Atlantic Standard */ + { "adt", tDAYZONE, HOUR( 4) }, /* Atlantic Daylight */ + { "est", tZONE, HOUR( 5) }, /* Eastern Standard */ + { "edt", tDAYZONE, HOUR( 5) }, /* Eastern Daylight */ + { "cst", tZONE, HOUR( 6) }, /* Central Standard */ + { "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */ + { "mst", tZONE, HOUR( 7) }, /* Mountain Standard */ + { "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */ + { "pst", tZONE, HOUR( 8) }, /* Pacific Standard */ + { "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */ + { "yst", tZONE, HOUR( 9) }, /* Yukon Standard */ + { "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */ + { "hst", tZONE, HOUR(10) }, /* Hawaii Standard */ + { "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */ + { "cat", tZONE, HOUR(10) }, /* Central Alaska */ + { "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */ + { "nt", tZONE, HOUR(11) }, /* Nome */ + { "idlw", tZONE, HOUR(12) }, /* International Date Line West */ + { "cet", tZONE, -HOUR( 1) }, /* Central European */ + { "met", tZONE, -HOUR( 1) }, /* Middle European */ + { "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */ + { "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */ + { "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */ + { "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */ + { "fwt", tZONE, -HOUR( 1) }, /* French Winter */ + { "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */ + { "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */ + { "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */ + { "it", tZONE, -HOUR( 7/2) }, /* Iran */ + { "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */ + { "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */ + { "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */ + { "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */ +#if 0 + /* For completeness. NST is also Newfoundland Stanard, nad SST is + * also Swedish Summer. */ + { "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */ + { "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */ +#endif /* 0 */ + { "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */ + { "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */ + { "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */ + { "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */ + { "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */ + { "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */ + { "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */ + { "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */ + { "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */ + { "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */ + { "nzt", tZONE, -HOUR(12) }, /* New Zealand */ + { "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */ + { "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */ + { "idle", tZONE, -HOUR(12) }, /* International Date Line East */ + /* ADDED BY Marco Nijdam */ + { "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */ + /* End ADDED */ + { NULL } +}; + +/* + * Military timezone table. + */ +static TABLE MilitaryTable[] = { + { "a", tZONE, HOUR( 1) }, + { "b", tZONE, HOUR( 2) }, + { "c", tZONE, HOUR( 3) }, + { "d", tZONE, HOUR( 4) }, + { "e", tZONE, HOUR( 5) }, + { "f", tZONE, HOUR( 6) }, + { "g", tZONE, HOUR( 7) }, + { "h", tZONE, HOUR( 8) }, + { "i", tZONE, HOUR( 9) }, + { "k", tZONE, HOUR( 10) }, + { "l", tZONE, HOUR( 11) }, + { "m", tZONE, HOUR( 12) }, + { "n", tZONE, HOUR(- 1) }, + { "o", tZONE, HOUR(- 2) }, + { "p", tZONE, HOUR(- 3) }, + { "q", tZONE, HOUR(- 4) }, + { "r", tZONE, HOUR(- 5) }, + { "s", tZONE, HOUR(- 6) }, + { "t", tZONE, HOUR(- 7) }, + { "u", tZONE, HOUR(- 8) }, + { "v", tZONE, HOUR(- 9) }, + { "w", tZONE, HOUR(-10) }, + { "x", tZONE, HOUR(-11) }, + { "y", tZONE, HOUR(-12) }, + { "z", tZONE, HOUR( 0) }, + { NULL } +}; + + +/* + * Dump error messages in the bit bucket. + */ +static void +TclDateerror(s) + char *s; +{ +} + + +static time_t +ToSeconds(Hours, Minutes, Seconds, Meridian) + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; +{ + if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) + return -1; + switch (Meridian) { + case MER24: + if (Hours < 0 || Hours > 23) + return -1; + return (Hours * 60L + Minutes) * 60L + Seconds; + case MERam: + if (Hours < 1 || Hours > 12) + return -1; + return ((Hours % 12) * 60L + Minutes) * 60L + Seconds; + case MERpm: + if (Hours < 1 || Hours > 12) + return -1; + return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds; + } + return -1; /* Should never be reached */ +} + + +static int +Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr) + time_t Month; + time_t Day; + time_t Year; + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; + DSTMODE DSTmode; + time_t *TimePtr; +{ + static int DaysInMonth[12] = { + 31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 + }; + time_t tod; + time_t Julian; + int i; + + DaysInMonth[1] = Year % 4 == 0 && (Year % 100 != 0 || Year % 400 == 0) + ? 29 : 28; + if (Month < 1 || Month > 12 + || Year < START_OF_TIME || Year > END_OF_TIME + || Day < 1 || Day > DaysInMonth[(int)--Month]) + return -1; + + for (Julian = Day - 1, i = 0; i < Month; i++) + Julian += DaysInMonth[i]; + if (Year >= EPOCH) { + for (i = EPOCH; i < Year; i++) + Julian += 365 + (i % 4 == 0); + } else { + for (i = Year; i < EPOCH; i++) + Julian -= 365 + (i % 4 == 0); + } + Julian *= SECSPERDAY; + Julian += TclDateTimezone * 60L; + if ((tod = ToSeconds(Hours, Minutes, Seconds, Meridian)) < 0) + return -1; + Julian += tod; + if (DSTmode == DSTon + || (DSTmode == DSTmaybe && TclpGetDate(&Julian, 0)->tm_isdst)) + Julian -= 60 * 60; + *TimePtr = Julian; + return 0; +} + + +static time_t +DSTcorrect(Start, Future) + time_t Start; + time_t Future; +{ + time_t StartDay; + time_t FutureDay; + + StartDay = (TclpGetDate(&Start, 0)->tm_hour + 1) % 24; + FutureDay = (TclpGetDate(&Future, 0)->tm_hour + 1) % 24; + return (Future - Start) + (StartDay - FutureDay) * 60L * 60L; +} + + +static time_t +RelativeDate(Start, DayOrdinal, DayNumber) + time_t Start; + time_t DayOrdinal; + time_t DayNumber; +{ + struct tm *tm; + time_t now; + + now = Start; + tm = TclpGetDate(&now, 0); + now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7); + now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1); + return DSTcorrect(Start, now); +} + + +static int +RelativeMonth(Start, RelMonth, TimePtr) + time_t Start; + time_t RelMonth; + time_t *TimePtr; +{ + struct tm *tm; + time_t Month; + time_t Year; + time_t Julian; + int result; + + if (RelMonth == 0) { + *TimePtr = 0; + return 0; + } + tm = TclpGetDate(&Start, 0); + Month = 12 * (tm->tm_year + TM_YEAR_BASE) + tm->tm_mon + RelMonth; + Year = Month / 12; + Month = Month % 12 + 1; + result = Convert(Month, (time_t) tm->tm_mday, Year, + (time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec, + MER24, DSTmaybe, &Julian); + /* + * The following iteration takes into account the case were we jump + * into a "short month". Far example, "one month from Jan 31" will + * fail because there is no Feb 31. The code below will reduce the + * day and try converting the date until we succed or the date equals + * 28 (which always works unless the date is bad in another way). + */ + + while ((result != 0) && (tm->tm_mday > 28)) { + tm->tm_mday--; + result = Convert(Month, (time_t) tm->tm_mday, Year, + (time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec, + MER24, DSTmaybe, &Julian); + } + if (result != 0) { + return -1; + } + *TimePtr = DSTcorrect(Start, Julian); + return 0; +} + + +static int +LookupWord(buff) + char *buff; +{ + register char *p; + register char *q; + register TABLE *tp; + int i; + int abbrev; + + /* + * Make it lowercase. + */ + for (p = buff; *p; p++) { + if (isupper(UCHAR(*p))) { + *p = (char) tolower(UCHAR(*p)); + } + } + + if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) { + TclDatelval.Meridian = MERam; + return tMERIDIAN; + } + if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) { + TclDatelval.Meridian = MERpm; + return tMERIDIAN; + } + + /* + * See if we have an abbreviation for a month. + */ + if (strlen(buff) == 3) { + abbrev = 1; + } else if (strlen(buff) == 4 && buff[3] == '.') { + abbrev = 1; + buff[3] = '\0'; + } else { + abbrev = 0; + } + + for (tp = MonthDayTable; tp->name; tp++) { + if (abbrev) { + if (strncmp(buff, tp->name, 3) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } else if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + /* + * Strip off any plural and try the units table again. + */ + i = strlen(buff) - 1; + if (buff[i] == 's') { + buff[i] = '\0'; + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + } + + for (tp = OtherTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + /* + * Military timezones. + */ + if (buff[1] == '\0' && isalpha(UCHAR(*buff))) { + for (tp = MilitaryTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + } + + /* + * Drop out any periods and try the timezone table again. + */ + for (i = 0, p = q = buff; *q; q++) + if (*q != '.') { + *p++ = *q; + } else { + i++; + } + *p = '\0'; + if (i) { + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + } + + return tID; +} + + +static int +TclDatelex() +{ + register char c; + register char *p; + char buff[20]; + int Count; + int sign; + + for ( ; ; ) { + while (isspace((unsigned char) (*TclDateInput))) { + TclDateInput++; + } + + if (isdigit(c = *TclDateInput) || c == '-' || c == '+') { + if (c == '-' || c == '+') { + sign = c == '-' ? -1 : 1; + if (!isdigit(*++TclDateInput)) { + /* + * skip the '-' sign + */ + continue; + } + } else { + sign = 0; + } + for (TclDatelval.Number = 0; isdigit(c = *TclDateInput++); ) { + TclDatelval.Number = 10 * TclDatelval.Number + c - '0'; + } + TclDateInput--; + if (sign < 0) { + TclDatelval.Number = -TclDatelval.Number; + } + return sign ? tSNUMBER : tUNUMBER; + } + if (isalpha(UCHAR(c))) { + for (p = buff; isalpha(c = *TclDateInput++) || c == '.'; ) { + if (p < &buff[sizeof buff - 1]) { + *p++ = c; + } + } + *p = '\0'; + TclDateInput--; + return LookupWord(buff); + } + if (c != '(') { + return *TclDateInput++; + } + Count = 0; + do { + c = *TclDateInput++; + if (c == '\0') { + return c; + } else if (c == '(') { + Count++; + } else if (c == ')') { + Count--; + } + } while (Count > 0); + } +} + +/* + * Specify zone is of -50000 to force GMT. (This allows BST to work). + */ + +int +TclGetDate(p, now, zone, timePtr) + char *p; + unsigned long now; + long zone; + unsigned long *timePtr; +{ + struct tm *tm; + time_t Start; + time_t Time; + time_t tod; + int thisyear; + + TclDateInput = p; + tm = TclpGetDate((time_t *) &now, 0); + thisyear = tm->tm_year + TM_YEAR_BASE; + TclDateYear = thisyear; + TclDateMonth = tm->tm_mon + 1; + TclDateDay = tm->tm_mday; + TclDateTimezone = zone; + if (zone == -50000) { + TclDateDSTmode = DSToff; /* assume GMT */ + TclDateTimezone = 0; + } else { + TclDateDSTmode = DSTmaybe; + } + TclDateHour = 0; + TclDateMinutes = 0; + TclDateSeconds = 0; + TclDateMeridian = MER24; + TclDateRelSeconds = 0; + TclDateRelMonth = 0; + TclDateHaveDate = 0; + TclDateHaveDay = 0; + TclDateHaveRel = 0; + TclDateHaveTime = 0; + TclDateHaveZone = 0; + + if (TclDateparse() || TclDateHaveTime > 1 || TclDateHaveZone > 1 || TclDateHaveDate > 1 || + TclDateHaveDay > 1) { + return -1; + } + + if (TclDateHaveDate || TclDateHaveTime || TclDateHaveDay) { + if (TclDateYear < 0) { + TclDateYear = -TclDateYear; + } + /* + * The following line handles years that are specified using + * only two digits. The line of code below implements a policy + * defined by the X/Open workgroup on the millinium rollover. + * Note: some of those dates may not actually be valid on some + * platforms. The POSIX standard startes that the dates 70-99 + * shall refer to 1970-1999 and 00-38 shall refer to 2000-2038. + * This later definition should work on all platforms. + */ + + if (TclDateYear < 100) { + if (TclDateYear >= 69) { + TclDateYear += 1900; + } else { + TclDateYear += 2000; + } + } + if (Convert(TclDateMonth, TclDateDay, TclDateYear, TclDateHour, TclDateMinutes, TclDateSeconds, + TclDateMeridian, TclDateDSTmode, &Start) < 0) { + return -1; + } + } else { + Start = now; + if (!TclDateHaveRel) { + Start -= ((tm->tm_hour * 60L) + tm->tm_min * 60L) + tm->tm_sec; + } + } + + Start += TclDateRelSeconds; + if (RelativeMonth(Start, TclDateRelMonth, &Time) < 0) { + return -1; + } + Start += Time; + + if (TclDateHaveDay && !TclDateHaveDate) { + tod = RelativeDate(Start, TclDateDayOrdinal, TclDateDayNumber); + Start += tod; + } + + *timePtr = Start; + return 0; +} +TclDatetabelem TclDateexca[] ={ +-1, 1, + 0, -1, + -2, 0, + }; +# define YYNPROD 41 +# define YYLAST 227 +TclDatetabelem TclDateact[]={ + + 14, 11, 23, 28, 17, 12, 19, 18, 16, 9, + 10, 13, 42, 21, 46, 45, 44, 48, 41, 37, + 36, 35, 32, 29, 34, 33, 31, 43, 39, 38, + 30, 15, 8, 7, 6, 5, 4, 3, 2, 1, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 47, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 22, 0, 0, 20, 25, 24, 27, + 26, 42, 0, 0, 0, 0, 40 }; +TclDatetabelem TclDatepact[]={ + +-10000000, -258,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000, -45, + -267,-10000000, -244,-10000000, -14, -231, -240,-10000000,-10000000,-10000000, +-10000000, -246,-10000000, -247, -248,-10000000,-10000000,-10000000,-10000000, -15, +-10000000,-10000000,-10000000,-10000000,-10000000, -40, -20,-10000000, -251,-10000000, +-10000000, -252,-10000000, -253,-10000000, -249,-10000000,-10000000,-10000000 }; +TclDatetabelem TclDatepgo[]={ + + 0, 28, 39, 38, 37, 36, 35, 34, 33, 32, + 31 }; +TclDatetabelem TclDater1[]={ + + 0, 2, 2, 3, 3, 3, 3, 3, 3, 4, + 4, 4, 4, 4, 5, 5, 5, 7, 7, 7, + 6, 6, 6, 6, 6, 6, 6, 8, 8, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 9, 1, + 1 }; +TclDatetabelem TclDater2[]={ + + 0, 0, 4, 3, 3, 3, 3, 3, 2, 5, + 9, 9, 13, 13, 5, 3, 3, 3, 5, 5, + 7, 11, 5, 9, 5, 3, 7, 5, 2, 5, + 5, 3, 5, 5, 3, 5, 5, 3, 3, 1, + 3 }; +TclDatetabelem TclDatechk[]={ + +-10000000, -2, -3, -4, -5, -6, -7, -8, -9, 267, + 268, 259, 263, 269, 258, -10, 266, 262, 265, 264, + 261, 58, 258, 47, 263, 262, 265, 264, 270, 267, + 44, 257, 262, 265, 264, 267, 267, 267, 44, -1, + 266, 58, 261, 47, 267, 267, 267, -1, 266 }; +TclDatetabelem TclDatedef[]={ + + 1, -2, 2, 3, 4, 5, 6, 7, 8, 38, + 15, 16, 0, 25, 17, 28, 0, 31, 34, 37, + 9, 0, 19, 0, 24, 29, 33, 36, 14, 22, + 18, 27, 30, 32, 35, 39, 20, 26, 0, 10, + 11, 0, 40, 0, 23, 39, 21, 12, 13 }; +typedef struct +#ifdef __cplusplus + TclDatetoktype +#endif +{ char *t_name; int t_val; } TclDatetoktype; +#ifndef YYDEBUG +# define YYDEBUG 0 /* don't allow debugging */ +#endif + +#if YYDEBUG + +TclDatetoktype TclDatetoks[] = +{ + "tAGO", 257, + "tDAY", 258, + "tDAYZONE", 259, + "tID", 260, + "tMERIDIAN", 261, + "tMINUTE_UNIT", 262, + "tMONTH", 263, + "tMONTH_UNIT", 264, + "tSEC_UNIT", 265, + "tSNUMBER", 266, + "tUNUMBER", 267, + "tZONE", 268, + "tEPOCH", 269, + "tDST", 270, + "-unknown-", -1 /* ends search */ +}; + +char * TclDatereds[] = +{ + "-no such reduction-", + "spec : /* empty */", + "spec : spec item", + "item : time", + "item : zone", + "item : date", + "item : day", + "item : rel", + "item : number", + "time : tUNUMBER tMERIDIAN", + "time : tUNUMBER ':' tUNUMBER o_merid", + "time : tUNUMBER ':' tUNUMBER tSNUMBER", + "time : tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid", + "time : tUNUMBER ':' tUNUMBER ':' tUNUMBER tSNUMBER", + "zone : tZONE tDST", + "zone : tZONE", + "zone : tDAYZONE", + "day : tDAY", + "day : tDAY ','", + "day : tUNUMBER tDAY", + "date : tUNUMBER '/' tUNUMBER", + "date : tUNUMBER '/' tUNUMBER '/' tUNUMBER", + "date : tMONTH tUNUMBER", + "date : tMONTH tUNUMBER ',' tUNUMBER", + "date : tUNUMBER tMONTH", + "date : tEPOCH", + "date : tUNUMBER tMONTH tUNUMBER", + "rel : relunit tAGO", + "rel : relunit", + "relunit : tUNUMBER tMINUTE_UNIT", + "relunit : tSNUMBER tMINUTE_UNIT", + "relunit : tMINUTE_UNIT", + "relunit : tSNUMBER tSEC_UNIT", + "relunit : tUNUMBER tSEC_UNIT", + "relunit : tSEC_UNIT", + "relunit : tSNUMBER tMONTH_UNIT", + "relunit : tUNUMBER tMONTH_UNIT", + "relunit : tMONTH_UNIT", + "number : tUNUMBER", + "o_merid : /* empty */", + "o_merid : tMERIDIAN", +}; +#endif /* YYDEBUG */ +/* + * Copyright (c) 1993 by Sun Microsystems, Inc. + */ + + +/* +** Skeleton parser driver for yacc output +*/ + +/* +** yacc user known macros and defines +*/ +#define YYERROR goto TclDateerrlab +#define YYACCEPT return(0) +#define YYABORT return(1) +#define YYBACKUP( newtoken, newvalue )\ +{\ + if ( TclDatechar >= 0 || ( TclDater2[ TclDatetmp ] >> 1 ) != 1 )\ + {\ + TclDateerror( "syntax error - cannot backup" );\ + goto TclDateerrlab;\ + }\ + TclDatechar = newtoken;\ + TclDatestate = *TclDateps;\ + TclDatelval = newvalue;\ + goto TclDatenewstate;\ +} +#define YYRECOVERING() (!!TclDateerrflag) +#define YYNEW(type) malloc(sizeof(type) * TclDatenewmax) +#define YYCOPY(to, from, type) \ + (type *) memcpy(to, (char *) from, TclDatenewmax * sizeof(type)) +#define YYENLARGE( from, type) \ + (type *) realloc((char *) from, TclDatenewmax * sizeof(type)) +#ifndef YYDEBUG +# define YYDEBUG 1 /* make debugging available */ +#endif + +/* +** user known globals +*/ +int TclDatedebug; /* set to 1 to get debugging */ + +/* +** driver internal defines +*/ +#define YYFLAG (-10000000) + +/* +** global variables used by the parser +*/ +YYSTYPE *TclDatepv; /* top of value stack */ +int *TclDateps; /* top of state stack */ + +int TclDatestate; /* current state */ +int TclDatetmp; /* extra var (lasts between blocks) */ + +int TclDatenerrs; /* number of errors */ +int TclDateerrflag; /* error recovery flag */ +int TclDatechar; /* current input token number */ + + + +#ifdef YYNMBCHARS +#define YYLEX() TclDatecvtok(TclDatelex()) +/* +** TclDatecvtok - return a token if i is a wchar_t value that exceeds 255. +** If i<255, i itself is the token. If i>255 but the neither +** of the 30th or 31st bit is on, i is already a token. +*/ +#if defined(__STDC__) || defined(__cplusplus) +int TclDatecvtok(int i) +#else +int TclDatecvtok(i) int i; +#endif +{ + int first = 0; + int last = YYNMBCHARS - 1; + int mid; + wchar_t j; + + if(i&0x60000000){/*Must convert to a token. */ + if( TclDatembchars[last].character < i ){ + return i;/*Giving up*/ + } + while ((last>=first)&&(first>=0)) {/*Binary search loop*/ + mid = (first+last)/2; + j = TclDatembchars[mid].character; + if( j==i ){/*Found*/ + return TclDatembchars[mid].tvalue; + }else if( j<i ){ + first = mid + 1; + }else{ + last = mid -1; + } + } + /*No entry in the table.*/ + return i;/* Giving up.*/ + }else{/* i is already a token. */ + return i; + } +} +#else/*!YYNMBCHARS*/ +#define YYLEX() TclDatelex() +#endif/*!YYNMBCHARS*/ + +/* +** TclDateparse - return 0 if worked, 1 if syntax error not recovered from +*/ +#if defined(__STDC__) || defined(__cplusplus) +int TclDateparse(void) +#else +int TclDateparse() +#endif +{ + register YYSTYPE *TclDatepvt; /* top of value stack for $vars */ + +#if defined(__cplusplus) || defined(lint) +/* + hacks to please C++ and lint - goto's inside switch should never be + executed; TclDatepvt is set to 0 to avoid "used before set" warning. +*/ + static int __yaccpar_lint_hack__ = 0; + switch (__yaccpar_lint_hack__) + { + case 1: goto TclDateerrlab; + case 2: goto TclDatenewstate; + } + TclDatepvt = 0; +#endif + + /* + ** Initialize externals - TclDateparse may be called more than once + */ + TclDatepv = &TclDatev[-1]; + TclDateps = &TclDates[-1]; + TclDatestate = 0; + TclDatetmp = 0; + TclDatenerrs = 0; + TclDateerrflag = 0; + TclDatechar = -1; + +#if YYMAXDEPTH <= 0 + if (TclDatemaxdepth <= 0) + { + if ((TclDatemaxdepth = YYEXPAND(0)) <= 0) + { + TclDateerror("yacc initialization error"); + YYABORT; + } + } +#endif + + { + register YYSTYPE *TclDate_pv; /* top of value stack */ + register int *TclDate_ps; /* top of state stack */ + register int TclDate_state; /* current state */ + register int TclDate_n; /* internal state number info */ + goto TclDatestack; /* moved from 6 lines above to here to please C++ */ + + /* + ** get globals into registers. + ** branch to here only if YYBACKUP was called. + */ + TclDate_pv = TclDatepv; + TclDate_ps = TclDateps; + TclDate_state = TclDatestate; + goto TclDate_newstate; + + /* + ** get globals into registers. + ** either we just started, or we just finished a reduction + */ + TclDatestack: + TclDate_pv = TclDatepv; + TclDate_ps = TclDateps; + TclDate_state = TclDatestate; + + /* + ** top of for (;;) loop while no reductions done + */ + TclDate_stack: + /* + ** put a state and value onto the stacks + */ +#if YYDEBUG + /* + ** if debugging, look up token value in list of value vs. + ** name pairs. 0 and negative (-1) are special values. + ** Note: linear search is used since time is not a real + ** consideration while debugging. + */ + if ( TclDatedebug ) + { + register int TclDate_i; + + printf( "State %d, token ", TclDate_state ); + if ( TclDatechar == 0 ) + printf( "end-of-file\n" ); + else if ( TclDatechar < 0 ) + printf( "-none-\n" ); + else + { + for ( TclDate_i = 0; TclDatetoks[TclDate_i].t_val >= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val == TclDatechar ) + break; + } + printf( "%s\n", TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + if ( ++TclDate_ps >= &TclDates[ TclDatemaxdepth ] ) /* room on stack? */ + { + /* + ** reallocate and recover. Note that pointers + ** have to be reset, or bad things will happen + */ + int TclDateps_index = (TclDate_ps - TclDates); + int TclDatepv_index = (TclDate_pv - TclDatev); + int TclDatepvt_index = (TclDatepvt - TclDatev); + int TclDatenewmax; +#ifdef YYEXPAND + TclDatenewmax = YYEXPAND(TclDatemaxdepth); +#else + TclDatenewmax = 2 * TclDatemaxdepth; /* double table size */ + if (TclDatemaxdepth == YYMAXDEPTH) /* first time growth */ + { + char *newTclDates = (char *)YYNEW(int); + char *newTclDatev = (char *)YYNEW(YYSTYPE); + if (newTclDates != 0 && newTclDatev != 0) + { + TclDates = YYCOPY(newTclDates, TclDates, int); + TclDatev = YYCOPY(newTclDatev, TclDatev, YYSTYPE); + } + else + TclDatenewmax = 0; /* failed */ + } + else /* not first time */ + { + TclDates = YYENLARGE(TclDates, int); + TclDatev = YYENLARGE(TclDatev, YYSTYPE); + if (TclDates == 0 || TclDatev == 0) + TclDatenewmax = 0; /* failed */ + } +#endif + if (TclDatenewmax <= TclDatemaxdepth) /* tables not expanded */ + { + TclDateerror( "yacc stack overflow" ); + YYABORT; + } + TclDatemaxdepth = TclDatenewmax; + + TclDate_ps = TclDates + TclDateps_index; + TclDate_pv = TclDatev + TclDatepv_index; + TclDatepvt = TclDatev + TclDatepvt_index; + } + *TclDate_ps = TclDate_state; + *++TclDate_pv = TclDateval; + + /* + ** we have a new state - find out what to do + */ + TclDate_newstate: + if ( ( TclDate_n = TclDatepact[ TclDate_state ] ) <= YYFLAG ) + goto TclDatedefault; /* simple state */ +#if YYDEBUG + /* + ** if debugging, need to mark whether new token grabbed + */ + TclDatetmp = TclDatechar < 0; +#endif + if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) ) + TclDatechar = 0; /* reached EOF */ +#if YYDEBUG + if ( TclDatedebug && TclDatetmp ) + { + register int TclDate_i; + + printf( "Received token " ); + if ( TclDatechar == 0 ) + printf( "end-of-file\n" ); + else if ( TclDatechar < 0 ) + printf( "-none-\n" ); + else + { + for ( TclDate_i = 0; TclDatetoks[TclDate_i].t_val >= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val == TclDatechar ) + break; + } + printf( "%s\n", TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + if ( ( ( TclDate_n += TclDatechar ) < 0 ) || ( TclDate_n >= YYLAST ) ) + goto TclDatedefault; + if ( TclDatechk[ TclDate_n = TclDateact[ TclDate_n ] ] == TclDatechar ) /*valid shift*/ + { + TclDatechar = -1; + TclDateval = TclDatelval; + TclDate_state = TclDate_n; + if ( TclDateerrflag > 0 ) + TclDateerrflag--; + goto TclDate_stack; + } + + TclDatedefault: + if ( ( TclDate_n = TclDatedef[ TclDate_state ] ) == -2 ) + { +#if YYDEBUG + TclDatetmp = TclDatechar < 0; +#endif + if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) ) + TclDatechar = 0; /* reached EOF */ +#if YYDEBUG + if ( TclDatedebug && TclDatetmp ) + { + register int TclDate_i; + + printf( "Received token " ); + if ( TclDatechar == 0 ) + printf( "end-of-file\n" ); + else if ( TclDatechar < 0 ) + printf( "-none-\n" ); + else + { + for ( TclDate_i = 0; + TclDatetoks[TclDate_i].t_val >= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val + == TclDatechar ) + { + break; + } + } + printf( "%s\n", TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + /* + ** look through exception table + */ + { + register int *TclDatexi = TclDateexca; + + while ( ( *TclDatexi != -1 ) || + ( TclDatexi[1] != TclDate_state ) ) + { + TclDatexi += 2; + } + while ( ( *(TclDatexi += 2) >= 0 ) && + ( *TclDatexi != TclDatechar ) ) + ; + if ( ( TclDate_n = TclDatexi[1] ) < 0 ) + YYACCEPT; + } + } + + /* + ** check for syntax error + */ + if ( TclDate_n == 0 ) /* have an error */ + { + /* no worry about speed here! */ + switch ( TclDateerrflag ) + { + case 0: /* new error */ + TclDateerror( "syntax error" ); + goto skip_init; + /* + ** get globals into registers. + ** we have a user generated syntax type error + */ + TclDate_pv = TclDatepv; + TclDate_ps = TclDateps; + TclDate_state = TclDatestate; + skip_init: + TclDatenerrs++; + /* FALLTHRU */ + case 1: + case 2: /* incompletely recovered error */ + /* try again... */ + TclDateerrflag = 3; + /* + ** find state where "error" is a legal + ** shift action + */ + while ( TclDate_ps >= TclDates ) + { + TclDate_n = TclDatepact[ *TclDate_ps ] + YYERRCODE; + if ( TclDate_n >= 0 && TclDate_n < YYLAST && + TclDatechk[TclDateact[TclDate_n]] == YYERRCODE) { + /* + ** simulate shift of "error" + */ + TclDate_state = TclDateact[ TclDate_n ]; + goto TclDate_stack; + } + /* + ** current state has no shift on + ** "error", pop stack + */ +#if YYDEBUG +# define _POP_ "Error recovery pops state %d, uncovers state %d\n" + if ( TclDatedebug ) + printf( _POP_, *TclDate_ps, + TclDate_ps[-1] ); +# undef _POP_ +#endif + TclDate_ps--; + TclDate_pv--; + } + /* + ** there is no state on stack with "error" as + ** a valid shift. give up. + */ + YYABORT; + case 3: /* no shift yet; eat a token */ +#if YYDEBUG + /* + ** if debugging, look up token in list of + ** pairs. 0 and negative shouldn't occur, + ** but since timing doesn't matter when + ** debugging, it doesn't hurt to leave the + ** tests here. + */ + if ( TclDatedebug ) + { + register int TclDate_i; + + printf( "Error recovery discards " ); + if ( TclDatechar == 0 ) + printf( "token end-of-file\n" ); + else if ( TclDatechar < 0 ) + printf( "token -none-\n" ); + else + { + for ( TclDate_i = 0; + TclDatetoks[TclDate_i].t_val >= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val + == TclDatechar ) + { + break; + } + } + printf( "token %s\n", + TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + if ( TclDatechar == 0 ) /* reached EOF. quit */ + YYABORT; + TclDatechar = -1; + goto TclDate_newstate; + } + }/* end if ( TclDate_n == 0 ) */ + /* + ** reduction by production TclDate_n + ** put stack tops, etc. so things right after switch + */ +#if YYDEBUG + /* + ** if debugging, print the string that is the user's + ** specification of the reduction which is just about + ** to be done. + */ + if ( TclDatedebug ) + printf( "Reduce by (%d) \"%s\"\n", + TclDate_n, TclDatereds[ TclDate_n ] ); +#endif + TclDatetmp = TclDate_n; /* value to switch over */ + TclDatepvt = TclDate_pv; /* $vars top of value stack */ + /* + ** Look in goto table for next state + ** Sorry about using TclDate_state here as temporary + ** register variable, but why not, if it works... + ** If TclDater2[ TclDate_n ] doesn't have the low order bit + ** set, then there is no action to be done for + ** this reduction. So, no saving & unsaving of + ** registers done. The only difference between the + ** code just after the if and the body of the if is + ** the goto TclDate_stack in the body. This way the test + ** can be made before the choice of what to do is needed. + */ + { + /* length of production doubled with extra bit */ + register int TclDate_len = TclDater2[ TclDate_n ]; + + if ( !( TclDate_len & 01 ) ) + { + TclDate_len >>= 1; + TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */ + TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] + + *( TclDate_ps -= TclDate_len ) + 1; + if ( TclDate_state >= YYLAST || + TclDatechk[ TclDate_state = + TclDateact[ TclDate_state ] ] != -TclDate_n ) + { + TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ]; + } + goto TclDate_stack; + } + TclDate_len >>= 1; + TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */ + TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] + + *( TclDate_ps -= TclDate_len ) + 1; + if ( TclDate_state >= YYLAST || + TclDatechk[ TclDate_state = TclDateact[ TclDate_state ] ] != -TclDate_n ) + { + TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ]; + } + } + /* save until reenter driver code */ + TclDatestate = TclDate_state; + TclDateps = TclDate_ps; + TclDatepv = TclDate_pv; + } + /* + ** code supplied by user is placed in this switch + */ + switch( TclDatetmp ) + { + +case 3:{ + TclDateHaveTime++; + } break; +case 4:{ + TclDateHaveZone++; + } break; +case 5:{ + TclDateHaveDate++; + } break; +case 6:{ + TclDateHaveDay++; + } break; +case 7:{ + TclDateHaveRel++; + } break; +case 9:{ + TclDateHour = TclDatepvt[-1].Number; + TclDateMinutes = 0; + TclDateSeconds = 0; + TclDateMeridian = TclDatepvt[-0].Meridian; + } break; +case 10:{ + TclDateHour = TclDatepvt[-3].Number; + TclDateMinutes = TclDatepvt[-1].Number; + TclDateSeconds = 0; + TclDateMeridian = TclDatepvt[-0].Meridian; + } break; +case 11:{ + TclDateHour = TclDatepvt[-3].Number; + TclDateMinutes = TclDatepvt[-1].Number; + TclDateMeridian = MER24; + TclDateDSTmode = DSToff; + TclDateTimezone = - (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60); + } break; +case 12:{ + TclDateHour = TclDatepvt[-5].Number; + TclDateMinutes = TclDatepvt[-3].Number; + TclDateSeconds = TclDatepvt[-1].Number; + TclDateMeridian = TclDatepvt[-0].Meridian; + } break; +case 13:{ + TclDateHour = TclDatepvt[-5].Number; + TclDateMinutes = TclDatepvt[-3].Number; + TclDateSeconds = TclDatepvt[-1].Number; + TclDateMeridian = MER24; + TclDateDSTmode = DSToff; + TclDateTimezone = - (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60); + } break; +case 14:{ + TclDateTimezone = TclDatepvt[-1].Number; + TclDateDSTmode = DSTon; + } break; +case 15:{ + TclDateTimezone = TclDatepvt[-0].Number; + TclDateDSTmode = DSToff; + } break; +case 16:{ + TclDateTimezone = TclDatepvt[-0].Number; + TclDateDSTmode = DSTon; + } break; +case 17:{ + TclDateDayOrdinal = 1; + TclDateDayNumber = TclDatepvt[-0].Number; + } break; +case 18:{ + TclDateDayOrdinal = 1; + TclDateDayNumber = TclDatepvt[-1].Number; + } break; +case 19:{ + TclDateDayOrdinal = TclDatepvt[-1].Number; + TclDateDayNumber = TclDatepvt[-0].Number; + } break; +case 20:{ + TclDateMonth = TclDatepvt[-2].Number; + TclDateDay = TclDatepvt[-0].Number; + } break; +case 21:{ + TclDateMonth = TclDatepvt[-4].Number; + TclDateDay = TclDatepvt[-2].Number; + TclDateYear = TclDatepvt[-0].Number; + } break; +case 22:{ + TclDateMonth = TclDatepvt[-1].Number; + TclDateDay = TclDatepvt[-0].Number; + } break; +case 23:{ + TclDateMonth = TclDatepvt[-3].Number; + TclDateDay = TclDatepvt[-2].Number; + TclDateYear = TclDatepvt[-0].Number; + } break; +case 24:{ + TclDateMonth = TclDatepvt[-0].Number; + TclDateDay = TclDatepvt[-1].Number; + } break; +case 25:{ + TclDateMonth = 1; + TclDateDay = 1; + TclDateYear = EPOCH; + } break; +case 26:{ + TclDateMonth = TclDatepvt[-1].Number; + TclDateDay = TclDatepvt[-2].Number; + TclDateYear = TclDatepvt[-0].Number; + } break; +case 27:{ + TclDateRelSeconds = -TclDateRelSeconds; + TclDateRelMonth = -TclDateRelMonth; + } break; +case 29:{ + TclDateRelSeconds += TclDatepvt[-1].Number * TclDatepvt[-0].Number * 60L; + } break; +case 30:{ + TclDateRelSeconds += TclDatepvt[-1].Number * TclDatepvt[-0].Number * 60L; + } break; +case 31:{ + TclDateRelSeconds += TclDatepvt[-0].Number * 60L; + } break; +case 32:{ + TclDateRelSeconds += TclDatepvt[-1].Number; + } break; +case 33:{ + TclDateRelSeconds += TclDatepvt[-1].Number; + } break; +case 34:{ + TclDateRelSeconds++; + } break; +case 35:{ + TclDateRelMonth += TclDatepvt[-1].Number * TclDatepvt[-0].Number; + } break; +case 36:{ + TclDateRelMonth += TclDatepvt[-1].Number * TclDatepvt[-0].Number; + } break; +case 37:{ + TclDateRelMonth += TclDatepvt[-0].Number; + } break; +case 38:{ + if (TclDateHaveTime && TclDateHaveDate && !TclDateHaveRel) { + TclDateYear = TclDatepvt[-0].Number; + } else { + TclDateHaveTime++; + if (TclDatepvt[-0].Number < 100) { + TclDateHour = 0; + TclDateMinutes = TclDatepvt[-0].Number; + } else { + TclDateHour = TclDatepvt[-0].Number / 100; + TclDateMinutes = TclDatepvt[-0].Number % 100; + } + TclDateSeconds = 0; + TclDateMeridian = MER24; + } + } break; +case 39:{ + TclDateval.Meridian = MER24; + } break; +case 40:{ + TclDateval.Meridian = TclDatepvt[-0].Meridian; + } break; + } + goto TclDatestack; /* reset registers in driver code */ +} + diff --git a/tcl/generic/tclEnv.c b/tcl/generic/tclEnv.c new file mode 100644 index 00000000000..f67918b506d --- /dev/null +++ b/tcl/generic/tclEnv.c @@ -0,0 +1,829 @@ +/* + * tclEnv.c -- + * + * Tcl support for environment variables, including a setenv + * procedure. This file contains the generic portion of the + * environment module. It is primarily responsible for keeping + * the "env" arrays in sync with the system environment variables. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* CYGNUS LOCAL */ +#ifdef __CYGWIN32__ + +/* On cygwin32, the environment is imported from the cygwin32 DLL. */ + +extern char ***__imp___cygwin_environ; + +#define environ (*__imp___cygwin_environ) + +/* We need to use a special putenv function to handle PATH. */ +#ifndef USE_PUTENV +#define USE_PUTENV +#endif +#define putenv TclCygwin32Putenv + +#endif +/* END CYGNUS LOCAL */ + +/* + * The structure below is used to keep track of all of the interpereters + * for which we're managing the "env" array. It's needed so that they + * can all be updated whenever an environment variable is changed + * anywhere. + */ + +typedef struct EnvInterp { + Tcl_Interp *interp; /* Interpreter for which we're managing + * the env array. */ + struct EnvInterp *nextPtr; /* Next in list of all such interpreters, + * or zero. */ +} EnvInterp; + +static EnvInterp *firstInterpPtr = NULL; + /* First in list of all managed interpreters, + * or NULL if none. */ + +static int cacheSize = 0; /* Number of env strings in environCache. */ +static char **environCache = NULL; + /* Array containing all of the environment + * strings that Tcl has allocated. */ + +#ifndef USE_PUTENV +static int environSize = 0; /* Non-zero means that the environ array was + * malloced and has this many total entries + * allocated to it (not all may be in use at + * once). Zero means that the environment + * array is in its original static state. */ +#endif + +/* + * Declarations for local procedures defined in this file: + */ + +static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static int FindVariable _ANSI_ARGS_((CONST char *name, + int *lengthPtr)); +static void ReplaceString _ANSI_ARGS_((CONST char *oldStr, + char *newStr)); +void TclSetEnv _ANSI_ARGS_((CONST char *name, + CONST char *value)); +void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); + +/* CYGNUS LOCAL */ +#ifdef __CYGWIN32__ +static void TclCygwin32Putenv _ANSI_ARGS_((CONST char *string)); +#endif + +/* + *---------------------------------------------------------------------- + * + * TclSetupEnv -- + * + * This procedure is invoked for an interpreter to make environment + * variables accessible from that interpreter via the "env" + * associative array. + * + * Results: + * None. + * + * Side effects: + * The interpreter is added to a list of interpreters managed + * by us, so that its view of envariables can be kept consistent + * with the view in other interpreters. If this is the first + * call to Tcl_SetupEnv, then additional initialization happens, + * such as copying the environment to dynamically-allocated space + * for ease of management. + * + *---------------------------------------------------------------------- + */ + +void +TclSetupEnv(interp) + Tcl_Interp *interp; /* Interpreter whose "env" array is to be + * managed. */ +{ + EnvInterp *eiPtr; + char *p, *p2; + Tcl_DString ds; + int i, sz; + +#ifdef MAC_TCL + if (environ == NULL) { + environSize = TclMacCreateEnv(); + } +#endif + + /* + * Next, initialize the DString we are going to use for copying + * the names of the environment variables. + */ + + Tcl_DStringInit(&ds); + + /* + * Next, add the interpreter to the list of those that we manage. + */ + + eiPtr = (EnvInterp *) ckalloc(sizeof(EnvInterp)); + eiPtr->interp = interp; + eiPtr->nextPtr = firstInterpPtr; + firstInterpPtr = eiPtr; + + /* + * Store the environment variable values into the interpreter's + * "env" array, and arrange for us to be notified on future + * writes and unsets to that array. + */ + + (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); + for (i = 0; ; i++) { + p = environ[i]; + if (p == NULL) { + break; + } + for (p2 = p; *p2 != '='; p2++) { + if (*p2 == 0) { + /* + * This condition doesn't seem like it should ever happen, + * but it does seem to happen occasionally under some + * versions of Solaris; ignore the entry. + */ + + goto nextEntry; + } + } + sz = p2 - p; + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, p, sz); + (void) Tcl_SetVar2(interp, "env", Tcl_DStringValue(&ds), + p2+1, TCL_GLOBAL_ONLY); + nextEntry: + continue; + } + Tcl_TraceVar2(interp, "env", (char *) NULL, + TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, + EnvTraceProc, (ClientData) NULL); + + /* + * Finally clean up the DString. + */ + + Tcl_DStringFree(&ds); +} + +/* + *---------------------------------------------------------------------- + * + * TclSetEnv -- + * + * Set an environment variable, replacing an existing value + * or creating a new variable if there doesn't exist a variable + * by the given name. This procedure is intended to be a + * stand-in for the UNIX "setenv" procedure so that applications + * using that procedure will interface properly to Tcl. To make + * it a stand-in, the Makefile must define "TclSetEnv" to "setenv". + * + * Results: + * None. + * + * Side effects: + * The environ array gets updated, as do all of the interpreters + * that we manage. + * + *---------------------------------------------------------------------- + */ + +void +TclSetEnv(name, value) + CONST char *name; /* Name of variable whose value is to be + * set. */ + CONST char *value; /* New value for variable. */ +{ + int index, length, nameLength; + char *p, *oldValue; + EnvInterp *eiPtr; + +#ifdef MAC_TCL + if (environ == NULL) { + environSize = TclMacCreateEnv(); + } +#endif + + /* + * Figure out where the entry is going to go. If the name doesn't + * already exist, enlarge the array if necessary to make room. If + * the name exists, free its old entry. + */ + + index = FindVariable(name, &length); + if (index == -1) { +#ifndef USE_PUTENV + if ((length+2) > environSize) { + char **newEnviron; + + newEnviron = (char **) ckalloc((unsigned) + ((length+5) * sizeof(char *))); + + /* CYGNUS LOCAL: Added to avoid an error from Purify, + although I don't personally see where the error would + occur--ian. */ + memset((VOID *) newEnviron, 0, (length+5) * sizeof(char *)); + + memcpy((VOID *) newEnviron, (VOID *) environ, + length*sizeof(char *)); + if (environSize != 0) { + ckfree((char *) environ); + } + environ = newEnviron; + environSize = length+5; + } + index = length; + environ[index+1] = NULL; +#endif + oldValue = NULL; + nameLength = strlen(name); + } else { + /* + * Compare the new value to the existing value. If they're + * the same then quit immediately (e.g. don't rewrite the + * value or propagate it to other interpreters). Otherwise, + * when there are N interpreters there will be N! propagations + * of the same value among the interpreters. + */ + + if (strcmp(value, environ[index]+length+1) == 0) { + return; + } + oldValue = environ[index]; + nameLength = length; + } + + + /* + * Create a new entry. + */ + + p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2)); + strcpy(p, name); + p[nameLength] = '='; + strcpy(p+nameLength+1, value); + + /* + * Update the system environment. + */ + +#ifdef USE_PUTENV + putenv(p); +#else + environ[index] = p; +#endif + + /* + * Replace the old value with the new value in the cache. + */ + + ReplaceString(oldValue, p); + + /* + * Update all of the interpreters. + */ + + /* CYGNUS LOCAL: The original code was bogus. If we are being + called because of a trace on the env array, then the call to + Tcl_SetVar2 would free value. We avoid that by checking + whether the value is the same before calling Tcl_SetVar2. + + NOTE: This is not necessary in tcl8.1a2 which handles this in a + completely different, and better, way. */ + + for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { + CONST char *v; + + v = Tcl_GetVar2(eiPtr->interp, "env", (char *) name, TCL_GLOBAL_ONLY); + if (v == NULL || (v != value && strcmp (v, value) != 0)) { + (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name, + (char *) value, TCL_GLOBAL_ONLY); + } + } + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PutEnv -- + * + * Set an environment variable. Similar to setenv except that + * the information is passed in a single string of the form + * NAME=value, rather than as separate name strings. This procedure + * is intended to be a stand-in for the UNIX "putenv" procedure + * so that applications using that procedure will interface + * properly to Tcl. To make it a stand-in, the Makefile will + * define "Tcl_PutEnv" to "putenv". + * + * Results: + * None. + * + * Side effects: + * The environ array gets updated, as do all of the interpreters + * that we manage. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_PutEnv(string) + CONST char *string; /* Info about environment variable in the + * form NAME=value. */ +{ + int nameLength; + char *name, *value; + + if (string == NULL) { + return 0; + } + + /* + * Separate the string into name and value parts, then call + * TclSetEnv to do all of the real work. + */ + + value = strchr(string, '='); + if (value == NULL) { + return 0; + } + nameLength = value - string; + if (nameLength == 0) { + return 0; + } + name = (char *) ckalloc((unsigned) nameLength+1); + memcpy((VOID *) name, (VOID *) string, (size_t) nameLength); + name[nameLength] = 0; + TclSetEnv(name, value+1); + ckfree(name); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclUnsetEnv -- + * + * Remove an environment variable, updating the "env" arrays + * in all interpreters managed by us. This function is intended + * to replace the UNIX "unsetenv" function (but to do this the + * Makefile must be modified to redefine "TclUnsetEnv" to + * "unsetenv". + * + * Results: + * None. + * + * Side effects: + * Interpreters are updated, as is environ. + * + *---------------------------------------------------------------------- + */ + +void +TclUnsetEnv(name) + CONST char *name; /* Name of variable to remove. */ +{ + EnvInterp *eiPtr; + char *oldValue; + int length, index; +#ifdef USE_PUTENV + char *string; +#else + char **envPtr; +#endif + +#ifdef MAC_TCL + if (environ == NULL) { + environSize = TclMacCreateEnv(); + } +#endif + + index = FindVariable(name, &length); + + /* + * First make sure that the environment variable exists to avoid + * doing needless work and to avoid recursion on the unset. + */ + + if (index == -1) { + return; + } + /* + * Remember the old value so we can free it if Tcl created the string. + */ + + oldValue = environ[index]; + + /* + * Update the system environment. This must be done before we + * update the interpreters or we will recurse. + */ + +#ifdef USE_PUTENV + string = ckalloc(length+2); + memcpy((VOID *) string, (VOID *) name, (size_t) length); + string[length] = '='; + string[length+1] = '\0'; + putenv(string); + ckfree(string); +#else + for (envPtr = environ+index+1; ; envPtr++) { + envPtr[-1] = *envPtr; + if (*envPtr == NULL) { + break; + } + } +#endif + + /* + * Replace the old value in the cache. + */ + + ReplaceString(oldValue, NULL); + + /* + * Update all of the interpreters. + */ + + for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { + (void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name, + TCL_GLOBAL_ONLY); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetEnv -- + * + * Retrieve the value of an environment variable. + * + * Results: + * Returns a pointer to a static string in the environment, + * or NULL if the value was not found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetEnv(name) + CONST char *name; /* Name of variable to find. */ +{ + int length, index; + +#ifdef MAC_TCL + if (environ == NULL) { + environSize = TclMacCreateEnv(); + } +#endif + + index = FindVariable(name, &length); + if ((index != -1) && (*(environ[index]+length) == '=')) { + return environ[index]+length+1; + } else { + return NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * EnvTraceProc -- + * + * This procedure is invoked whenever an environment variable + * is modified or deleted. It propagates the change to the + * "environ" array and to any other interpreters for whom + * we're managing an "env" array. + * + * Results: + * Always returns NULL to indicate success. + * + * Side effects: + * Environment variable changes get propagated. If the whole + * "env" array is deleted, then we stop managing things for + * this interpreter (usually this happens because the whole + * interpreter is being deleted). + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +EnvTraceProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter whose "env" variable is + * being modified. */ + char *name1; /* Better be "env". */ + char *name2; /* Name of variable being modified, or + * NULL if whole array is being deleted. */ + int flags; /* Indicates what's happening. */ +{ + /* + * First see if the whole "env" variable is being deleted. If + * so, just forget about this interpreter. + */ + + if (name2 == NULL) { + register EnvInterp *eiPtr, *prevPtr; + + if ((flags & (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) + != (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) { + panic("EnvTraceProc called with confusing arguments"); + } + eiPtr = firstInterpPtr; + if (eiPtr->interp == interp) { + firstInterpPtr = eiPtr->nextPtr; + } else { + for (prevPtr = eiPtr, eiPtr = eiPtr->nextPtr; ; + prevPtr = eiPtr, eiPtr = eiPtr->nextPtr) { + if (eiPtr == NULL) { + panic("EnvTraceProc couldn't find interpreter"); + } + if (eiPtr->interp == interp) { + prevPtr->nextPtr = eiPtr->nextPtr; + break; + } + } + } + ckfree((char *) eiPtr); + return NULL; + } + + /* + * If a value is being set, call TclSetEnv to do all of the work. + */ + + if (flags & TCL_TRACE_WRITES) { + TclSetEnv(name2, Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY)); + } + + if (flags & TCL_TRACE_UNSETS) { + TclUnsetEnv(name2); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ReplaceString -- + * + * Replace one string with another in the environment variable + * cache. The cache keeps track of all of the environment + * variables that Tcl has modified so they can be freed later. + * + * Results: + * None. + * + * Side effects: + * May free the old string. + * + *---------------------------------------------------------------------- + */ + +static void +ReplaceString(oldStr, newStr) + CONST char *oldStr; /* Old environment string. */ + char *newStr; /* New environment string. */ +{ + int i; + char **newCache; + + /* + * Check to see if the old value was allocated by Tcl. If so, + * it needs to be deallocated to avoid memory leaks. Note that this + * algorithm is O(n), not O(1). This will result in n-squared behavior + * if lots of environment changes are being made. + */ + + for (i = 0; i < cacheSize; i++) { + if ((environCache[i] == oldStr) || (environCache[i] == NULL)) { + break; + } + } + if (i < cacheSize) { + /* + * Replace or delete the old value. + */ + + if (environCache[i]) { + ckfree(environCache[i]); + } + + if (newStr) { + environCache[i] = newStr; + } else { + for (; i < cacheSize-1; i++) { + environCache[i] = environCache[i+1]; + } + environCache[cacheSize-1] = NULL; + } + } else { + int allocatedSize = (cacheSize + 5) * sizeof(char *); + + /* + * We need to grow the cache in order to hold the new string. + */ + + newCache = (char **) ckalloc((size_t) allocatedSize); + (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize); + + if (environCache) { + memcpy((VOID *) newCache, (VOID *) environCache, + (size_t) (cacheSize * sizeof(char*))); + ckfree((char *) environCache); + } + environCache = newCache; + environCache[cacheSize] = (char *) newStr; + environCache[cacheSize+1] = NULL; + cacheSize += 5; + } +} + +/* + *---------------------------------------------------------------------- + * + * FindVariable -- + * + * Locate the entry in environ for a given name. + * + * Results: + * The return value is the index in environ of an entry with the + * name "name", or -1 if there is no such entry. The integer at + * *lengthPtr is filled in with the length of name (if a matching + * entry is found) or the length of the environ array (if no matching + * entry is found). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FindVariable(name, lengthPtr) + CONST char *name; /* Name of desired environment variable. */ + int *lengthPtr; /* Used to return length of name (for + * successful searches) or number of non-NULL + * entries in environ (for unsuccessful + * searches). */ +{ + int i; + register CONST char *p1, *p2; + + for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) { + for (p2 = name; *p2 == *p1; p1++, p2++) { + /* NULL loop body. */ + } + if ((*p1 == '=') && (*p2 == '\0')) { + *lengthPtr = p2-name; + return i; + } + } + *lengthPtr = i; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeEnvironment -- + * + * This function releases any storage allocated by this module + * that isn't still in use by the global environment. Any + * strings that are still in the environment will be leaked. + * + * Results: + * None. + * + * Side effects: + * May deallocate storage. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeEnvironment() +{ + /* + * For now we just deallocate the cache array and none of the environment + * strings. This may leak more memory that strictly necessary, since some + * of the strings may no longer be in the environment. However, + * determining which ones are ok to delete is n-squared, and is pretty + * unlikely, so we don't bother. + */ + + if (environCache) { + ckfree((char *) environCache); + environCache = NULL; + cacheSize = 0; +#ifndef USE_PUTENV + environSize = 0; +#endif + } +} + +/* CYGNUS LOCAL */ +#ifdef __CYGWIN32__ + +#include "windows.h" + +/* When using cygwin32, when an environment variable changes, we need + to synch with both the cygwin32 environment (in case the + application C code calls fork) and the Windows environment (in case + the application TCL code calls exec, which calls the Windows + CreateProcess function). */ + +static void +TclCygwin32Putenv(str) + const char *str; +{ + char *name, *value; + + /* Get the name and value, so that we can change the environment + variable for Windows. */ + name = (char *) alloca (strlen (str) + 1); + strcpy (name, str); + for (value = name; *value != '=' && *value != '\0'; ++value) + ; + if (*value == '\0') + { + /* Can't happen. */ + return; + } + *value = '\0'; + ++value; + if (*value == '\0') + value = NULL; + + /* Set the cygwin32 environment variable. */ +#undef putenv + if (value == NULL) + unsetenv (name); + else + putenv(str); + + /* Before changing the environment variable in Windows, if this is + PATH, we need to convert the value back to a Windows style path. + + FIXME: The calling program may now it is running under windows, + and may have set the path to a Windows path, or, worse, appended + or prepended a Windows path to PATH. */ + if (strcmp (name, "PATH") != 0) + { + /* If this is Path, eliminate any PATH variable, to prevent any + confusion. */ + if (strcmp (name, "Path") == 0) + { + SetEnvironmentVariable ("PATH", (char *) NULL); + unsetenv ("PATH"); + } + + SetEnvironmentVariable (name, value); + } + else + { + char *buf; + + /* Eliminate any Path variable, to prevent any confusion. */ + SetEnvironmentVariable ("Path", (char *) NULL); + unsetenv ("Path"); + + if (value == NULL) + buf = NULL; + else + { + int size; + + size = cygwin32_posix_to_win32_path_list_buf_size (value); + buf = (char *) alloca (size + 1); + cygwin32_posix_to_win32_path_list (value, buf); + } + + SetEnvironmentVariable (name, buf); + } +} + +#endif /* __CYGWIN32__ */ +/* END CYGNUS LOCAL */ diff --git a/tcl/generic/tclEvent.c b/tcl/generic/tclEvent.c new file mode 100644 index 00000000000..554878884a3 --- /dev/null +++ b/tcl/generic/tclEvent.c @@ -0,0 +1,698 @@ +/* + * tclEvent.c -- + * + * This file implements some general event related interfaces including + * background errors, exit handlers, and the "vwait" and "update" + * command procedures. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The data structure below is used to report background errors. One + * such structure is allocated for each error; it holds information + * about the interpreter and the error until bgerror can be invoked + * later as an idle handler. + */ + +typedef struct BgError { + Tcl_Interp *interp; /* Interpreter in which error occurred. NULL + * means this error report has been cancelled + * (a previous report generated a break). */ + char *errorMsg; /* The error message (interp->result when + * the error occurred). Malloc-ed. */ + char *errorInfo; /* Value of the errorInfo variable + * (malloc-ed). */ + char *errorCode; /* Value of the errorCode variable + * (malloc-ed). */ + struct BgError *nextPtr; /* Next in list of all pending error + * reports for this interpreter, or NULL + * for end of list. */ +} BgError; + +/* + * One of the structures below is associated with the "tclBgError" + * assoc data for each interpreter. It keeps track of the head and + * tail of the list of pending background errors for the interpreter. + */ + +typedef struct ErrAssocData { + BgError *firstBgPtr; /* First in list of all background errors + * waiting to be processed for this + * interpreter (NULL if none). */ + BgError *lastBgPtr; /* Last in list of all background errors + * waiting to be processed for this + * interpreter (NULL if none). */ +} ErrAssocData; + +/* + * For each exit handler created with a call to Tcl_CreateExitHandler + * there is a structure of the following type: + */ + +typedef struct ExitHandler { + Tcl_ExitProc *proc; /* Procedure to call when process exits. */ + ClientData clientData; /* One word of information to pass to proc. */ + struct ExitHandler *nextPtr;/* Next in list of all exit handlers for + * this application, or NULL for end of list. */ +} ExitHandler; + +static ExitHandler *firstExitPtr = NULL; + /* First in list of all exit handlers for + * application. */ + +/* + * The following variable is a "secret" indication to Tcl_Exit that + * it should dump out the state of memory before exiting. If the + * value is non-NULL, it gives the name of the file in which to + * dump memory usage information. + */ + +char *tclMemDumpFileName = NULL; + +/* + * This variable is set to 1 when Tcl_Exit is called, and at the end of + * its work, it is reset to 0. The variable is checked by TclInExit() to + * allow different behavior for exit-time processing, e.g. in closing of + * files and pipes. + */ + +static int tclInExit = 0; + +/* + * Prototypes for procedures referenced only in this file: + */ + +static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void HandleBgErrors _ANSI_ARGS_((ClientData clientData)); +static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_BackgroundError -- + * + * This procedure is invoked to handle errors that occur in Tcl + * commands that are invoked in "background" (e.g. from event or + * timer bindings). + * + * Results: + * None. + * + * Side effects: + * The command "bgerror" is invoked later as an idle handler to + * process the error, passing it the error message. If that fails, + * then an error message is output on stderr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_BackgroundError(interp) + Tcl_Interp *interp; /* Interpreter in which an error has + * occurred. */ +{ + BgError *errPtr; + char *errResult, *varValue; + ErrAssocData *assocPtr; + + /* + * The Tcl_AddErrorInfo call below (with an empty string) ensures that + * errorInfo gets properly set. It's needed in cases where the error + * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval; + * in these cases errorInfo still won't have been set when this + * procedure is called. + */ + + Tcl_AddErrorInfo(interp, ""); + + errResult = TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL); + + errPtr = (BgError *) ckalloc(sizeof(BgError)); + errPtr->interp = interp; + errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(errResult) + 1)); + strcpy(errPtr->errorMsg, errResult); + varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + if (varValue == NULL) { + varValue = errPtr->errorMsg; + } + errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); + strcpy(errPtr->errorInfo, varValue); + varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); + if (varValue == NULL) { + varValue = ""; + } + errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); + strcpy(errPtr->errorCode, varValue); + errPtr->nextPtr = NULL; + + assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", + (Tcl_InterpDeleteProc **) NULL); + if (assocPtr == NULL) { + + /* + * This is the first time a background error has occurred in + * this interpreter. Create associated data to keep track of + * pending error reports. + */ + + assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); + assocPtr->firstBgPtr = NULL; + assocPtr->lastBgPtr = NULL; + Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, + (ClientData) assocPtr); + } + if (assocPtr->firstBgPtr == NULL) { + assocPtr->firstBgPtr = errPtr; + Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr); + } else { + assocPtr->lastBgPtr->nextPtr = errPtr; + } + assocPtr->lastBgPtr = errPtr; + Tcl_ResetResult(interp); +} + +/* + *---------------------------------------------------------------------- + * + * HandleBgErrors -- + * + * This procedure is invoked as an idle handler to process all of + * the accumulated background errors. + * + * Results: + * None. + * + * Side effects: + * Depends on what actions "bgerror" takes for the errors. + * + *---------------------------------------------------------------------- + */ + +static void +HandleBgErrors(clientData) + ClientData clientData; /* Pointer to ErrAssocData structure. */ +{ + Tcl_Interp *interp; + char *command; + char *argv[2]; + int code; + BgError *errPtr; + ErrAssocData *assocPtr = (ErrAssocData *) clientData; + Tcl_Channel errChannel; + + Tcl_Preserve((ClientData) assocPtr); + + while (assocPtr->firstBgPtr != NULL) { + interp = assocPtr->firstBgPtr->interp; + if (interp == NULL) { + goto doneWithInterp; + } + + /* + * Restore important state variables to what they were at + * the time the error occurred. + */ + + Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo, + TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode, + TCL_GLOBAL_ONLY); + + /* + * Create and invoke the bgerror command. + */ + + argv[0] = "bgerror"; + argv[1] = assocPtr->firstBgPtr->errorMsg; + command = Tcl_Merge(2, argv); + Tcl_AllowExceptions(interp); + Tcl_Preserve((ClientData) interp); + code = Tcl_GlobalEval(interp, command); + ckfree(command); + if (code == TCL_ERROR) { + + /* + * If the interpreter is safe, we look for a hidden command + * named "bgerror" and call that with the error information. + * Otherwise, simply ignore the error. The rationale is that + * this could be an error caused by a malicious applet trying + * to cause an infinite barrage of error messages. The hidden + * "bgerror" command can be used by a security policy to + * interpose on such attacks and e.g. kill the applet after a + * few attempts. + */ + + if (Tcl_IsSafe(interp)) { + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclHiddenCmds", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + goto doneWithInterp; + } + hPtr = Tcl_FindHashEntry(hTblPtr, "bgerror"); + if (hPtr == (Tcl_HashEntry *) NULL) { + goto doneWithInterp; + } + + /* + * OK, the hidden command "bgerror" exists, invoke it. + */ + + argv[0] = "bgerror"; + argv[1] = ckalloc((unsigned) + strlen(assocPtr->firstBgPtr->errorMsg)); + strcpy(argv[1], assocPtr->firstBgPtr->errorMsg); + (void) TclInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN); + ckfree(argv[1]); + + goto doneWithInterp; + } + + /* + * We have to get the error output channel at the latest possible + * time, because the eval (above) might have changed the channel. + */ + + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel != (Tcl_Channel) NULL) { + if (strcmp(interp->result, + "\"bgerror\" is an invalid command name or ambiguous abbreviation") + == 0) { + Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1); + Tcl_Write(errChannel, "\n", -1); + } else { + Tcl_Write(errChannel, + "bgerror failed to handle background error.\n", + -1); + Tcl_Write(errChannel, " Original error: ", -1); + Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg, + -1); + Tcl_Write(errChannel, "\n", -1); + Tcl_Write(errChannel, " Error in bgerror: ", -1); + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", -1); + } + Tcl_Flush(errChannel); + } + } else if (code == TCL_BREAK) { + + /* + * Break means cancel any remaining error reports for this + * interpreter. + */ + + for (errPtr = assocPtr->firstBgPtr; errPtr != NULL; + errPtr = errPtr->nextPtr) { + if (errPtr->interp == interp) { + errPtr->interp = NULL; + } + } + } + + /* + * Discard the command and the information about the error report. + */ + +doneWithInterp: + + if (assocPtr->firstBgPtr) { + ckfree(assocPtr->firstBgPtr->errorMsg); + ckfree(assocPtr->firstBgPtr->errorInfo); + ckfree(assocPtr->firstBgPtr->errorCode); + errPtr = assocPtr->firstBgPtr->nextPtr; + ckfree((char *) assocPtr->firstBgPtr); + assocPtr->firstBgPtr = errPtr; + } + + if (interp != NULL) { + Tcl_Release((ClientData) interp); + } + } + assocPtr->lastBgPtr = NULL; + + Tcl_Release((ClientData) assocPtr); +} + +/* + *---------------------------------------------------------------------- + * + * BgErrorDeleteProc -- + * + * This procedure is associated with the "tclBgError" assoc data + * for an interpreter; it is invoked when the interpreter is + * deleted in order to free the information assoicated with any + * pending error reports. + * + * Results: + * None. + * + * Side effects: + * Background error information is freed: if there were any + * pending error reports, they are cancelled. + * + *---------------------------------------------------------------------- + */ + +static void +BgErrorDeleteProc(clientData, interp) + ClientData clientData; /* Pointer to ErrAssocData structure. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + ErrAssocData *assocPtr = (ErrAssocData *) clientData; + BgError *errPtr; + + while (assocPtr->firstBgPtr != NULL) { + errPtr = assocPtr->firstBgPtr; + assocPtr->firstBgPtr = errPtr->nextPtr; + ckfree(errPtr->errorMsg); + ckfree(errPtr->errorInfo); + ckfree(errPtr->errorCode); + ckfree((char *) errPtr); + } + Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr); + Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateExitHandler -- + * + * Arrange for a given procedure to be invoked just before the + * application exits. + * + * Results: + * None. + * + * Side effects: + * Proc will be invoked with clientData as argument when the + * application exits. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr; + + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); + exitPtr->proc = proc; + exitPtr->clientData = clientData; + exitPtr->nextPtr = firstExitPtr; + firstExitPtr = exitPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteExitHandler -- + * + * This procedure cancels an existing exit handler matching proc + * and clientData, if such a handler exits. + * + * Results: + * None. + * + * Side effects: + * If there is an exit handler corresponding to proc and clientData + * then it is cancelled; if no such handler exists then nothing + * happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure that was previously registered. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr, *prevPtr; + + for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; + prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { + if ((exitPtr->proc == proc) + && (exitPtr->clientData == clientData)) { + if (prevPtr == NULL) { + firstExitPtr = exitPtr->nextPtr; + } else { + prevPtr->nextPtr = exitPtr->nextPtr; + } + ckfree((char *) exitPtr); + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Exit -- + * + * This procedure is called to terminate the application. + * + * Results: + * None. + * + * Side effects: + * All existing exit handlers are invoked, then the application + * ends. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Exit(status) + int status; /* Exit status for application; typically + * 0 for normal return, 1 for error return. */ +{ + Tcl_Finalize(); +#ifdef TCL_MEM_DEBUG + if (tclMemDumpFileName != NULL) { + Tcl_DumpActiveMemory(tclMemDumpFileName); + } +#endif + TclPlatformExit(status); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Finalize -- + * + * Runs the exit handlers to allow Tcl to clean up its state prior + * to being unloaded. Called by Tcl_Exit and when Tcl was dynamically + * loaded and is now being unloaded. + * + * Results: + * None. + * + * Side effects: + * Whatever the exit handlers do. Also frees up storage associated + * with the Tcl object type table. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Finalize() +{ + ExitHandler *exitPtr; + + /* + * Invoke exit handler first. + */ + + tclInExit = 1; + for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { + /* + * Be careful to remove the handler from the list before invoking + * its callback. This protects us against double-freeing if the + * callback should call Tcl_DeleteExitHandler on itself. + */ + + firstExitPtr = exitPtr->nextPtr; + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); + } + + /* + * Now finalize the Tcl execution environment. Note that this must be done + * after the exit handlers, because there are order dependencies. + */ + + TclFinalizeCompExecEnv(); + TclFinalizeEnvironment(); + TclpFinalize(); + firstExitPtr = NULL; + tclInExit = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclInExit -- + * + * Determines if we are in the middle of exit-time cleanup. + * + * Results: + * If we are in the middle of exiting, 1, otherwise 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclInExit() +{ + return tclInExit; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VwaitCmd -- + * + * This procedure is invoked to process the "vwait" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_VwaitCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int done, foundEvent; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " name\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_TraceVar(interp, argv[1], + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + }; + done = 0; + foundEvent = 1; + while (!done && foundEvent) { + foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); + } + Tcl_UntraceVar(interp, argv[1], + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done); + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + if (!foundEvent) { + Tcl_AppendResult(interp, "can't wait for variable \"", argv[1], + "\": would wait forever", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + + /* ARGSUSED */ +static char * +VwaitVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + int *donePtr = (int *) clientData; + + *donePtr = 1; + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpdateCmd -- + * + * This procedure is invoked to process the "update" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UpdateCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int flags; + + if (argc == 1) { + flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; + } else if (argc == 2) { + if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be idletasks", (char *) NULL); + return TCL_ERROR; + } + flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?idletasks?\"", (char *) NULL); + return TCL_ERROR; + } + + while (Tcl_DoOneEvent(flags) != 0) { + /* Empty loop body */ + } + + /* + * Must clear the interpreter's result because event handlers could + * have executed commands. + */ + + Tcl_ResetResult(interp); + return TCL_OK; +} diff --git a/tcl/generic/tclExecute.c b/tcl/generic/tclExecute.c new file mode 100644 index 00000000000..fdfe08344b9 --- /dev/null +++ b/tcl/generic/tclExecute.c @@ -0,0 +1,4928 @@ +/* + * tclExecute.c -- + * + * This file contains procedures that execute byte-compiled Tcl + * commands. + * + * 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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclCompile.h" + +#ifdef NO_FLOAT_H +# include "../compat/float.h" +#else +# include <float.h> +#endif +#ifndef TCL_NO_MATH +#include "tclMath.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 + +/* + * Boolean flag indicating whether the Tcl bytecode interpreter has been + * initialized. + */ + +static int execInitialized = 0; + +/* + * Variable that controls whether execution tracing is enabled and, if so, + * what level of tracing is desired: + * 0: no execution tracing + * 1: trace invocations of Tcl procs only + * 2: trace invocations of all (not compiled away) commands + * 3: display each instruction executed + * This variable is linked to the Tcl variable "tcl_traceExec". + */ + +int tclTraceExec = 0; + +/* + * 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 + +/* + * Array of instruction names. + */ + +static char *opName[256]; + +/* + * Mapping from expression instruction opcodes to strings; used for error + * messages. Note that these entries must match the order and number of the + * expression opcodes (e.g., INST_LOR) in tclCompile.h. + */ + +static char *operatorStrings[] = { + "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", + "+", "-", "*", "/", "%", "+", "-", "~", "!", + "BUILTIN FUNCTION", "FUNCTION" +}; + +/* + * Mapping from Tcl result codes to strings; used for error and debugging + * messages. + */ + +#ifdef TCL_COMPILE_DEBUG +static char *resultStrings[] = { + "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" +}; +#endif /* TCL_COMPILE_DEBUG */ + +/* + * The following are statistics-related variables that record information + * about the bytecode compiler and interpreter's operation. This includes + * an array that records for each instruction how often it is executed. + */ + +#ifdef TCL_COMPILE_STATS +static long numExecutions = 0; +static int instructionCount[256]; +#endif /* TCL_COMPILE_STATS */ + +/* + * 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 + +/* + * Macro to adjust the program counter and restart the instruction execution + * loop after each instruction is executed. + */ + +#define ADJUST_PC(instBytes) \ + pc += instBytes; continue + +/* + * Macros used to cache often-referenced Tcl evaluation stack information + * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() + * pair must surround any call inside TclExecuteByteCode (and a few other + * procedures that use this scheme) that could result in a recursive call + * to TclExecuteByteCode. + */ + +#define CACHE_STACK_INFO() \ + stackPtr = eePtr->stackPtr; \ + stackTop = eePtr->stackTop + +#define DECACHE_STACK_INFO() \ + eePtr->stackTop = stackTop + +/* + * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT + * increments the object's ref count since it makes the stack have another + * reference pointing to the object. However, POP_OBJECT does not decrement + * the ref count. This is because the stack may hold the only reference to + * the object, so the object would be destroyed if its ref count were + * decremented before the caller had a chance to, e.g., store it in a + * variable. It is the caller's responsibility to decrement the ref count + * when it is finished with an object. + */ + +#define STK_ITEM(offset) (stackPtr[stackTop + (offset)]) +#define STK_OBJECT(offset) (STK_ITEM(offset).o) +#define STK_INT(offset) (STK_ITEM(offset).i) +#define STK_POINTER(offset) (STK_ITEM(offset).p) + +/* + * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT + * macro. The actual parameter might be an expression with side effects, + * and this ensures that it will be executed only once. + */ + +#define PUSH_OBJECT(objPtr) \ + Tcl_IncrRefCount(stackPtr[++stackTop].o = (objPtr)) + +#define POP_OBJECT() \ + (stackPtr[stackTop--].o) + +/* + * Macros used to trace instruction execution. The macros TRACE, + * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. + * O2S is only used in TRACE* calls to get a string from an object. + * + * NOTE THAT CLIENTS OF O2S ARE LIKELY TO FAIL IF THE OBJECT'S + * STRING REP CONTAINS NULLS. + */ + +#ifdef TCL_COMPILE_DEBUG + +#define O2S(objPtr) \ + Tcl_GetStringFromObj((objPtr), &length) + +#ifdef TCL_COMPILE_STATS +#define TRACE(a) \ + if (traceInstructions) { \ + fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \ + stackTop, (tclObjsAlloced - tclObjsFreed), \ + (unsigned int)(pc - codePtr->codeStart)); \ + printf a; \ + fflush(stdout); \ + } +#define TRACE_WITH_OBJ(a, objPtr) \ + if (traceInstructions) { \ + fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \ + stackTop, (tclObjsAlloced - tclObjsFreed), \ + (unsigned int)(pc - codePtr->codeStart)); \ + printf a; \ + bytes = Tcl_GetStringFromObj((objPtr), &length); \ + TclPrintSource(stdout, bytes, TclMin(length, 30)); \ + fprintf(stdout, "\n"); \ + fflush(stdout); \ + } +#else /* not TCL_COMPILE_STATS */ +#define TRACE(a) \ + if (traceInstructions) { \ + fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \ + (unsigned int)(pc - codePtr->codeStart)); \ + printf a; \ + fflush(stdout); \ + } +#define TRACE_WITH_OBJ(a, objPtr) \ + if (traceInstructions) { \ + fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \ + (unsigned int)(pc - codePtr->codeStart)); \ + printf a; \ + bytes = Tcl_GetStringFromObj((objPtr), &length); \ + TclPrintSource(stdout, bytes, TclMin(length, 30)); \ + fprintf(stdout, "\n"); \ + fflush(stdout); \ + } +#endif /* TCL_COMPILE_STATS */ + +#else /* not TCL_COMPILE_DEBUG */ + +#define TRACE(a) +#define TRACE_WITH_OBJ(a, objPtr) +#define O2S(objPtr) + +#endif /* TCL_COMPILE_DEBUG */ + +/* + * Declarations for local procedures to this file: + */ + +static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, + Trace *tracePtr, Command *cmdPtr, + char *command, int numChars, + int objc, Tcl_Obj *objv[])); +static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, + Tcl_Obj *copyPtr)); +static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, int objc, Tcl_Obj **objv)); +static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +#ifdef TCL_COMPILE_STATS +static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +#endif /* TCL_COMPILE_STATS */ +static void FreeCmdNameInternalRep _ANSI_ARGS_(( + Tcl_Obj *objPtr)); +static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, + ByteCode* codePtr, int *lengthPtr)); +static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); +static void IllegalExprOperandType _ANSI_ARGS_(( + Tcl_Interp *interp, unsigned int opCode, + Tcl_Obj *opndPtr)); +static void InitByteCodeExecution _ANSI_ARGS_(( + Tcl_Interp *interp)); +static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); +static void RecordTracebackInfo _ANSI_ARGS_((Tcl_Interp *interp, + unsigned char *pc, ByteCode *codePtr)); +static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +#ifdef TCL_COMPILE_DEBUG +static char * StringForResultCode _ANSI_ARGS_((int result)); +#endif /* TCL_COMPILE_DEBUG */ +static void UpdateStringOfCmdName _ANSI_ARGS_((Tcl_Obj *objPtr)); +#ifdef TCL_COMPILE_DEBUG +static void ValidatePcAndStackTop _ANSI_ARGS_(( + ByteCode *codePtr, unsigned char *pc, + int stackTop, int stackLowerBound, + int stackUpperBound)); +#endif /* TCL_COMPILE_DEBUG */ + +/* + * Table describing the built-in math functions. Entries in this table are + * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's + * operand byte. + */ + +BuiltinFunc builtinFuncTable[] = { +#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}, + {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */ + {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, + {"srand", 1, {TCL_INT}, ExprSrandFunc, 0}, + {0}, +}; + +/* + * The structure below defines the command name Tcl object type by means of + * procedures that can be invoked by generic object code. Objects of this + * type cache the Command pointer that results from looking up command names + * in the command hashtable. Such objects appear as the zeroth ("command + * name") argument in a Tcl command. + */ + +Tcl_ObjType tclCmdNameType = { + "cmdName", /* name */ + FreeCmdNameInternalRep, /* freeIntRepProc */ + DupCmdNameInternalRep, /* dupIntRepProc */ + UpdateStringOfCmdName, /* updateStringProc */ + SetCmdNameFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * InitByteCodeExecution -- + * + * This procedure is called once to initialize the Tcl bytecode + * interpreter. + * + * Results: + * None. + * + * Side effects: + * This procedure initializes the array of instruction names. If + * compiling with the TCL_COMPILE_STATS flag, it initializes the + * array that counts the executions of each instruction and it + * creates the "evalstats" command. It also registers the command name + * Tcl_ObjType. It also establishes the link between the Tcl + * "tcl_traceExec" and C "tclTraceExec" variables. + * + *---------------------------------------------------------------------- + */ + +static void +InitByteCodeExecution(interp) + Tcl_Interp *interp; /* Interpreter for which the Tcl variable + * "tcl_traceExec" is linked to control + * instruction tracing. */ +{ + int i; + + Tcl_RegisterObjType(&tclCmdNameType); + + (VOID *) memset(opName, 0, sizeof(opName)); + for (i = 0; instructionTable[i].name != NULL; i++) { + opName[i] = instructionTable[i].name; + } + +#ifdef TCL_COMPILE_STATS + (VOID *) memset(instructionCount, 0, sizeof(instructionCount)); + (VOID *) memset(tclByteCodeCount, 0, sizeof(tclByteCodeCount)); + (VOID *) memset(tclSourceCount, 0, sizeof(tclSourceCount)); + + Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd, + (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); +#endif /* TCL_COMPILE_STATS */ + + if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, + TCL_LINK_INT) != TCL_OK) { + panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateExecEnv -- + * + * This procedure creates a new execution environment for Tcl bytecode + * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv + * is typically created once for each Tcl interpreter (Interp + * structure) and recursively passed to TclExecuteByteCode to execute + * ByteCode sequences for nested commands. + * + * Results: + * A newly allocated ExecEnv is returned. This points to an empty + * evaluation stack of the standard initial size. + * + * Side effects: + * The bytecode interpreter is also initialized here, as this + * procedure will be called before any call to TclExecuteByteCode. + * + *---------------------------------------------------------------------- + */ + +#define TCL_STACK_INITIAL_SIZE 2000 + +ExecEnv * +TclCreateExecEnv(interp) + Tcl_Interp *interp; /* Interpreter for which the execution + * environment is being created. */ +{ + ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); + + eePtr->stackPtr = (StackItem *) + ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(StackItem))); + eePtr->stackTop = -1; + eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1); + + if (!execInitialized) { + TclInitAuxDataTypeTable(); + InitByteCodeExecution(interp); + execInitialized = 1; + } + + return eePtr; +} +#undef TCL_STACK_INITIAL_SIZE + +/* + *---------------------------------------------------------------------- + * + * TclDeleteExecEnv -- + * + * Frees the storage for an ExecEnv. + * + * Results: + * None. + * + * Side effects: + * Storage for an ExecEnv and its contained storage (e.g. the + * evaluation stack) is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclDeleteExecEnv(eePtr) + ExecEnv *eePtr; /* Execution environment to free. */ +{ + ckfree((char *) eePtr->stackPtr); + ckfree((char *) eePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeExecEnv -- + * + * Finalizes the execution environment setup so that it can be + * later reinitialized. + * + * Results: + * None. + * + * Side effects: + * After this call, the next time TclCreateExecEnv will be called + * it will call InitByteCodeExecution. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeExecEnv() +{ + execInitialized = 0; + TclFinalizeAuxDataTypeTable(); +} + +/* + *---------------------------------------------------------------------- + * + * GrowEvaluationStack -- + * + * This procedure grows a Tcl evaluation stack stored in an ExecEnv. + * + * Results: + * None. + * + * Side effects: + * The size of the evaluation stack is doubled. + * + *---------------------------------------------------------------------- + */ + +static void +GrowEvaluationStack(eePtr) + register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation + * stack to enlarge. */ +{ + /* + * The current Tcl stack elements are stored from eePtr->stackPtr[0] + * to eePtr->stackPtr[eePtr->stackEnd] (inclusive). + */ + + int currElems = (eePtr->stackEnd + 1); + int newElems = 2*currElems; + int currBytes = currElems * sizeof(StackItem); + int newBytes = 2*currBytes; + StackItem *newStackPtr = (StackItem *) ckalloc((unsigned) newBytes); + + /* + * Copy the existing stack items to the new stack space, free the old + * storage if appropriate, and mark new space as malloc'ed. + */ + + memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr, + (size_t) currBytes); + ckfree((char *) eePtr->stackPtr); + eePtr->stackPtr = newStackPtr; + eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */ +} + +/* + *---------------------------------------------------------------------- + * + * TclExecuteByteCode -- + * + * This procedure executes the instructions of a ByteCode structure. + * It returns when a "done" instruction is executed or an error occurs. + * + * Results: + * The return value is one of the return codes defined in tcl.h + * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object + * that either contains the result of executing the code or an + * error message. + * + * Side effects: + * Almost certainly, depending on the ByteCode's instructions. + * + *---------------------------------------------------------------------- + */ + +int +TclExecuteByteCode(interp, codePtr) + Tcl_Interp *interp; /* Token for command interpreter. */ + ByteCode *codePtr; /* The bytecode sequence to interpret. */ +{ + Interp *iPtr = (Interp *) interp; + ExecEnv *eePtr = iPtr->execEnvPtr; + /* Points to the execution environment. */ + register StackItem *stackPtr = eePtr->stackPtr; + /* Cached evaluation stack base pointer. */ + register int stackTop = eePtr->stackTop; + /* Cached top index of evaluation stack. */ + Tcl_Obj **objArrayPtr = codePtr->objArrayPtr; + /* Points to the ByteCode's object array. */ + unsigned char *pc = codePtr->codeStart; + /* The current program counter. */ + unsigned char opCode; /* The current instruction code. */ + int opnd; /* Current instruction's operand byte. */ + int pcAdjustment; /* Hold pc adjustment after instruction. */ + int initStackTop = stackTop;/* Stack top at start of execution. */ + ExceptionRange *rangePtr; /* Points to closest loop or catch exception + * range enclosing the pc. Used by various + * instructions and processCatch to + * process break, continue, and errors. */ + int result = TCL_OK; /* Return code returned after execution. */ + int traceInstructions = (tclTraceExec == 3); + Tcl_Obj *valuePtr, *value2Ptr, *namePtr, *objPtr; + char *bytes; + int length; + long i; + Tcl_DString command; /* Used for debugging. If tclTraceExec >= 2 + * holds a string representing the last + * command invoked. */ + + /* + * This procedure uses a stack to hold information about catch commands. + * This information is the current operand stack top when starting to + * execute the code for each catch command. It starts out with stack- + * allocated space but uses dynamically-allocated storage if needed. + */ + +#define STATIC_CATCH_STACK_SIZE 5 + int (catchStackStorage[STATIC_CATCH_STACK_SIZE]); + int *catchStackPtr = catchStackStorage; + int catchTop = -1; + + /* + * THIS PROC FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. + */ + + if (tclTraceExec >= 2) { + PrintByteCodeInfo(codePtr); +#ifdef TCL_COMPILE_STATS + fprintf(stdout, " Starting stack top=%d, system objects=%ld\n", + eePtr->stackTop, (tclObjsAlloced - tclObjsFreed)); +#else + fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop); +#endif /* TCL_COMPILE_STATS */ + fflush(stdout); + } + +#ifdef TCL_COMPILE_STATS + numExecutions++; +#endif /* TCL_COMPILE_STATS */ + + /* + * Make sure the catch stack is large enough to hold the maximum number + * of catch commands that could ever be executing at the same time. This + * will be no more than the exception range array's depth. + */ + + if (codePtr->maxExcRangeDepth > STATIC_CATCH_STACK_SIZE) { + catchStackPtr = (int *) + ckalloc(codePtr->maxExcRangeDepth * sizeof(int)); + } + + /* + * Make sure the stack has enough room to execute this ByteCode. + */ + + while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) { + GrowEvaluationStack(eePtr); + stackPtr = eePtr->stackPtr; + } + + /* + * Initialize the buffer that holds a string containing the name and + * arguments for the last invoked command. + */ + + Tcl_DStringInit(&command); + + /* + * Loop executing instructions until a "done" instruction, a TCL_RETURN, + * or some error. + */ + + for (;;) { +#ifdef TCL_COMPILE_DEBUG + ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop, + eePtr->stackEnd); +#else /* not TCL_COMPILE_DEBUG */ + if (traceInstructions) { +#ifdef TCL_COMPILE_STATS + fprintf(stdout, "%d: %d,%ld ", iPtr->numLevels, stackTop, + (tclObjsAlloced - tclObjsFreed)); +#else /* TCL_COMPILE_STATS */ + fprintf(stdout, "%d: %d ", iPtr->numLevels, stackTop); +#endif /* TCL_COMPILE_STATS */ + TclPrintInstruction(codePtr, pc); + fflush(stdout); + } +#endif /* TCL_COMPILE_DEBUG */ + + opCode = *pc; +#ifdef TCL_COMPILE_STATS + instructionCount[opCode]++; +#endif /* TCL_COMPILE_STATS */ + + switch (opCode) { + case INST_DONE: + /* + * Pop the topmost object from the stack, set the interpreter's + * object result to point to it, and return. + */ + valuePtr = POP_OBJECT(); + Tcl_SetObjResult(interp, valuePtr); + TclDecrRefCount(valuePtr); + if (stackTop != initStackTop) { + fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n", + (unsigned int)(pc - codePtr->codeStart), + (unsigned int) stackTop, + (unsigned int) initStackTop); + fprintf(stderr, " Source: "); + TclPrintSource(stderr, codePtr->source, 150); + panic("TclExecuteByteCode execution failure: end stack top != start stack top"); + } + TRACE_WITH_OBJ(("done => return code=%d, result is ", result), + iPtr->objResultPtr); + goto done; + + case INST_PUSH1: + valuePtr = objArrayPtr[TclGetUInt1AtPtr(pc+1)]; + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPtr(pc+1)), + valuePtr); + ADJUST_PC(2); + + case INST_PUSH4: + valuePtr = objArrayPtr[TclGetUInt4AtPtr(pc+1)]; + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPtr(pc+1)), + valuePtr); + ADJUST_PC(5); + + case INST_POP: + valuePtr = POP_OBJECT(); + TRACE_WITH_OBJ(("pop => discarding "), valuePtr); + TclDecrRefCount(valuePtr); /* finished with pop'ed object. */ + ADJUST_PC(1); + + case INST_DUP: + valuePtr = stackPtr[stackTop].o; + PUSH_OBJECT(Tcl_DuplicateObj(valuePtr)); + TRACE_WITH_OBJ(("dup => "), valuePtr); + ADJUST_PC(1); + + case INST_CONCAT1: + opnd = TclGetUInt1AtPtr(pc+1); + { + Tcl_Obj *concatObjPtr; + int totalLen = 0; + + /* + * Concatenate strings (with no separators) from the top + * opnd items on the stack starting with the deepest item. + * First, determine how many characters are needed. + */ + + for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { + valuePtr = stackPtr[i].o; + bytes = TclGetStringFromObj(valuePtr, &length); + if (bytes != NULL) { + totalLen += length; + } + } + + /* + * Initialize the new append string object by appending the + * strings of the opnd stack objects. Also pop the objects. + */ + + TclNewObj(concatObjPtr); + if (totalLen > 0) { + char *p = (char *) ckalloc((unsigned) (totalLen + 1)); + concatObjPtr->bytes = p; + concatObjPtr->length = totalLen; + for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { + valuePtr = stackPtr[i].o; + bytes = TclGetStringFromObj(valuePtr, &length); + if (bytes != NULL) { + memcpy((VOID *) p, (VOID *) bytes, + (size_t) length); + p += length; + } + TclDecrRefCount(valuePtr); + } + *p = '\0'; + } else { + for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { + valuePtr = stackPtr[i].o; + Tcl_DecrRefCount(valuePtr); + } + } + stackTop -= opnd; + + PUSH_OBJECT(concatObjPtr); + TRACE_WITH_OBJ(("concat %u => ", opnd), concatObjPtr); + ADJUST_PC(2); + } + + case INST_INVOKE_STK4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doInvocation; + + case INST_INVOKE_STK1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doInvocation: + { + char *cmdName; + Command *cmdPtr; /* Points to command's Command struct. */ + int objc = opnd; /* The number of arguments. */ + Tcl_Obj **objv; /* The array of argument objects. */ + Tcl_Obj *objv0Ptr; /* Holds objv[0], the command name. */ + int newPcOffset = 0; + /* Instruction offset computed during + * break, continue, error processing. + * Init. to avoid compiler warning. */ + Tcl_Command cmd; +#ifdef TCL_COMPILE_DEBUG + int isUnknownCmd = 0; + char cmdNameBuf[30]; +#endif /* TCL_COMPILE_DEBUG */ + + /* + * If the interpreter was deleted, return an error. + */ + + if (iPtr->flags & DELETED) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "attempt to call eval in deleted interpreter", -1); + Tcl_SetErrorCode(interp, "CORE", "IDELETE", + "attempt to call eval in deleted interpreter", + (char *) NULL); + result = TCL_ERROR; + goto checkForCatch; + } + + objv = &(stackPtr[stackTop - (objc-1)].o); + objv0Ptr = objv[0]; + cmdName = TclGetStringFromObj(objv0Ptr, (int *) NULL); + + /* + * Find the procedure to execute this command. If there + * isn't one, then see if there is a command "unknown". If + * so, invoke it, passing it the original command words as + * arguments. + * + * We convert the objv[0] object to be a CmdName object. + * This caches a pointer to the Command structure for the + * command; this pointer is held in a ResolvedCmdName + * structure the object's internal rep. points to. + */ + + cmd = Tcl_GetCommandFromObj(interp, objv0Ptr); + cmdPtr = (Command *) cmd; + + /* + * If the command is still not found, handle it with the + * "unknown" proc. + */ + + if (cmdPtr == NULL) { + cmd = Tcl_FindCommand(interp, "unknown", + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + if (cmd == (Tcl_Command) NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", cmdName, "\"", + (char *) NULL); + TRACE(("%s %u => unknown proc not found: ", + opName[opCode], objc)); + result = TCL_ERROR; + goto checkForCatch; + } + cmdPtr = (Command *) cmd; +#ifdef TCL_COMPILE_DEBUG + isUnknownCmd = 1; +#endif /*TCL_COMPILE_DEBUG*/ + stackTop++; /* need room for new inserted objv[0] */ + for (i = objc; i >= 0; i--) { + objv[i+1] = objv[i]; + } + objc++; + objv[0] = Tcl_NewStringObj("unknown", -1); + Tcl_IncrRefCount(objv[0]); + } + + /* + * Call any trace procedures. + */ + + if (iPtr->tracePtr != NULL) { + Trace *tracePtr, *nextTracePtr; + + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; + tracePtr = nextTracePtr) { + nextTracePtr = tracePtr->nextPtr; + if (iPtr->numLevels <= tracePtr->level) { + int numChars; + char *cmd = GetSrcInfoForPc(pc, codePtr, + &numChars); + if (cmd != NULL) { + DECACHE_STACK_INFO(); + CallTraceProcedure(interp, tracePtr, cmdPtr, + cmd, numChars, objc, objv); + CACHE_STACK_INFO(); + } + } + } + } + + /* + * Finally, invoke the command's Tcl_ObjCmdProc. First reset + * the interpreter's string and object results to their + * default empty values since they could have gotten changed + * by earlier invocations. + */ + + Tcl_ResetResult(interp); + + if (tclTraceExec >= 2) { + char buffer[50]; + + sprintf(buffer, "%d: (%u) invoking ", iPtr->numLevels, + (unsigned int)(pc - codePtr->codeStart)); + Tcl_DStringAppend(&command, buffer, -1); + +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { /* tclTraceExec == 3 */ + strncpy(cmdNameBuf, cmdName, 20); + TRACE(("%s %u => call ", opName[opCode], + (isUnknownCmd? objc-1 : objc))); + } else { + fprintf(stdout, "%s", buffer); + } +#else /* TCL_COMPILE_DEBUG */ + fprintf(stdout, "%s", buffer); +#endif /*TCL_COMPILE_DEBUG*/ + + for (i = 0; i < objc; i++) { + bytes = TclGetStringFromObj(objv[i], &length); + TclPrintSource(stdout, bytes, TclMin(length, 15)); + fprintf(stdout, " "); + + sprintf(buffer, "\"%.*s\" ", TclMin(length, 15), bytes); + Tcl_DStringAppend(&command, buffer, -1); + } + fprintf(stdout, "\n"); + fflush(stdout); + + Tcl_DStringFree(&command); + } + + iPtr->cmdCount++; + DECACHE_STACK_INFO(); + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, + objc, objv); + if (Tcl_AsyncReady()) { + result = Tcl_AsyncInvoke(interp, result); + } + CACHE_STACK_INFO(); + + /* + * If the interpreter has a non-empty string result, the + * result object is either empty or stale because some + * procedure set interp->result directly. If so, move the + * string result to the result object, then reset the + * string result. + */ + + if (*(iPtr->result) != 0) { + (void) Tcl_GetObjResult(interp); + } + + /* + * Pop the objc top stack elements and decrement their ref + * counts. + */ + + i = (stackTop - (objc-1)); + while (i <= stackTop) { + valuePtr = stackPtr[i].o; + TclDecrRefCount(valuePtr); + i++; + } + stackTop -= objc; + + /* + * Process the result of the Tcl_ObjCmdProc call. + */ + + switch (result) { + case TCL_OK: + /* + * Push the call's object result and continue execution + * with the next instruction. + */ + PUSH_OBJECT(Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%s %u => ...after \"%.20s\", result=", + opName[opCode], objc, cmdNameBuf), + Tcl_GetObjResult(interp)); + ADJUST_PC(pcAdjustment); + + case TCL_BREAK: + case TCL_CONTINUE: + /* + * The invoked command requested a break or continue. + * Find the closest enclosing loop or catch exception + * range, if any. If a loop is found, terminate its + * execution or skip to its next iteration. If the + * closest is a catch exception range, jump to its + * catchOffset. If no enclosing range is found, stop + * execution and return the TCL_BREAK or TCL_CONTINUE. + */ + rangePtr = TclGetExceptionRangeForPc(pc, + /*catchOnly*/ 0, codePtr); + if (rangePtr == NULL) { + TRACE(("%s %u => ... after \"%.20s\", no encl. loop or catch, returning %s\n", + opName[opCode], objc, cmdNameBuf, + StringForResultCode(result))); + goto abnormalReturn; /* no catch exists to check */ + } + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + if (result == TCL_BREAK) { + newPcOffset = rangePtr->breakOffset; + } else if (rangePtr->continueOffset == -1) { + TRACE(("%s %u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n", + opName[opCode], objc, cmdNameBuf, + StringForResultCode(result))); + goto checkForCatch; + } else { + newPcOffset = rangePtr->continueOffset; + } + TRACE(("%s %u => ... after \"%.20s\", %s, range at %d, new pc %d\n", + opName[opCode], objc, cmdNameBuf, + StringForResultCode(result), + rangePtr->codeOffset, newPcOffset)); + break; + case CATCH_EXCEPTION_RANGE: + TRACE(("%s %u => ... after \"%.20s\", %s...\n", + opName[opCode], objc, cmdNameBuf, + StringForResultCode(result))); + goto processCatch; /* it will use rangePtr */ + default: + panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); + } + result = TCL_OK; + pc = (codePtr->codeStart + newPcOffset); + continue; /* restart outer instruction loop at pc */ + + case TCL_ERROR: + /* + * The invoked command returned an error. Look for an + * enclosing catch exception range, if any. + */ + TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", TCL_ERROR ", + opName[opCode], objc, cmdNameBuf), + Tcl_GetObjResult(interp)); + goto checkForCatch; + + case TCL_RETURN: + /* + * The invoked command requested that the current + * procedure stop execution and return. First check + * for an enclosing catch exception range, if any. + */ + TRACE(("%s %u => ... after \"%.20s\", TCL_RETURN\n", + opName[opCode], objc, cmdNameBuf)); + goto checkForCatch; + + default: + TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", OTHER RETURN CODE %d ", + opName[opCode], objc, cmdNameBuf, result), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } /* end of switch on result from invoke instruction */ + } + + case INST_EVAL_STK: + objPtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + result = Tcl_EvalObj(interp, objPtr); + CACHE_STACK_INFO(); + if (result == TCL_OK) { + /* + * Normal return; push the eval's object result. + */ + + PUSH_OBJECT(Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("evalStk \"%.30s\" => ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + TclDecrRefCount(objPtr); + ADJUST_PC(1); + } else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) { + /* + * Find the closest enclosing loop or catch exception range, + * if any. If a loop is found, terminate its execution or + * skip to its next iteration. If the closest is a catch + * exception range, jump to its catchOffset. If no enclosing + * range is found, stop execution and return that same + * TCL_BREAK or TCL_CONTINUE. + */ + + int newPcOffset = 0; /* Pc offset computed during break, + * continue, error processing. Init. + * to avoid compiler warning. */ + + rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, + codePtr); + if (rangePtr == NULL) { + TRACE(("evalStk \"%.30s\" => no encl. loop or catch, returning %s\n", + O2S(objPtr), StringForResultCode(result))); + Tcl_DecrRefCount(objPtr); + goto abnormalReturn; /* no catch exists to check */ + } + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + if (result == TCL_BREAK) { + newPcOffset = rangePtr->breakOffset; + } else if (rangePtr->continueOffset == -1) { + TRACE(("evalStk \"%.30s\" => %s, loop w/o continue, checking for catch\n", + O2S(objPtr), StringForResultCode(result))); + Tcl_DecrRefCount(objPtr); + goto checkForCatch; + } else { + newPcOffset = rangePtr->continueOffset; + } + result = TCL_OK; + TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s, range at %d, new pc %d ", + O2S(objPtr), StringForResultCode(result), + rangePtr->codeOffset, newPcOffset), valuePtr); + break; + case CATCH_EXCEPTION_RANGE: + TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s ", + O2S(objPtr), StringForResultCode(result)), + valuePtr); + Tcl_DecrRefCount(objPtr); + goto processCatch; /* it will use rangePtr */ + default: + panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); + } + Tcl_DecrRefCount(objPtr); + pc = (codePtr->codeStart + newPcOffset); + continue; /* restart outer instruction loop at pc */ + } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */ + TRACE_WITH_OBJ(("evalStk \"%.30s\" => ERROR: ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(objPtr); + goto checkForCatch; + } + + case INST_EXPR_STK: + objPtr = POP_OBJECT(); + Tcl_ResetResult(interp); + DECACHE_STACK_INFO(); + result = Tcl_ExprObj(interp, objPtr, &valuePtr); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("exprStk \"%.30s\" => ERROR: ", + O2S(objPtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(objPtr); + goto checkForCatch; + } + stackPtr[++stackTop].o = valuePtr; /* already has right refct */ + TRACE_WITH_OBJ(("exprStk \"%.30s\" => ", O2S(objPtr)), valuePtr); + TclDecrRefCount(objPtr); + ADJUST_PC(1); + + case INST_LOAD_SCALAR4: + opnd = TclGetInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doLoadScalar; + + case INST_LOAD_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doLoadScalar: + DECACHE_STACK_INFO(); + valuePtr = TclGetIndexedScalar(interp, opnd, + /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("%s %u => ERROR: ", opName[opCode], opnd), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("%s %u => ", opName[opCode], opnd), valuePtr); + ADJUST_PC(pcAdjustment); + + case INST_LOAD_SCALAR_STK: + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + valuePtr = Tcl_ObjGetVar2(interp, namePtr, (Tcl_Obj *) NULL, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ERROR: ", + O2S(namePtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ", + O2S(namePtr)), valuePtr); + TclDecrRefCount(namePtr); + ADJUST_PC(1); + + case INST_LOAD_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doLoadArray; + + case INST_LOAD_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doLoadArray: + { + Tcl_Obj *elemPtr = POP_OBJECT(); + + DECACHE_STACK_INFO(); + valuePtr = TclGetElementOfIndexedArray(interp, opnd, + elemPtr, /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("%s %u \"%.30s\" => ERROR: ", + opName[opCode], opnd, O2S(elemPtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("%s %u \"%.30s\" => ", + opName[opCode], opnd, O2S(elemPtr)), valuePtr); + TclDecrRefCount(elemPtr); + } + ADJUST_PC(pcAdjustment); + + case INST_LOAD_ARRAY_STK: + { + Tcl_Obj *elemPtr = POP_OBJECT(); + + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + valuePtr = Tcl_ObjGetVar2(interp, namePtr, elemPtr, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ERROR: ", + O2S(namePtr), O2S(elemPtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ", + O2S(namePtr), O2S(elemPtr)), valuePtr); + TclDecrRefCount(namePtr); + TclDecrRefCount(elemPtr); + } + ADJUST_PC(1); + + case INST_LOAD_STK: + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + valuePtr = Tcl_ObjGetVar2(interp, namePtr, NULL, + TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("loadStk \"%.30s\" => ERROR: ", + O2S(namePtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("loadStk \"%.30s\" => ", O2S(namePtr)), + valuePtr); + TclDecrRefCount(namePtr); + ADJUST_PC(1); + + case INST_STORE_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doStoreScalar; + + case INST_STORE_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doStoreScalar: + valuePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr, + /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ERROR: ", + opName[opCode], opnd, O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ", + opName[opCode], opnd, O2S(valuePtr)), value2Ptr); + TclDecrRefCount(valuePtr); + ADJUST_PC(pcAdjustment); + + case INST_STORE_SCALAR_STK: + valuePtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ( + ("storeScalarStk \"%.30s\" <- \"%.30s\" => ERROR: ", + O2S(namePtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ( + ("storeScalarStk \"%.30s\" <- \"%.30s\" => ", + O2S(namePtr), + O2S(valuePtr)), + value2Ptr); + TclDecrRefCount(namePtr); + TclDecrRefCount(valuePtr); + ADJUST_PC(1); + + case INST_STORE_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doStoreArray; + + case INST_STORE_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doStoreArray: + { + Tcl_Obj *elemPtr; + + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclSetElementOfIndexedArray(interp, opnd, + elemPtr, valuePtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ( + ("%s %u \"%.30s\" <- \"%.30s\" => ERROR: ", + opName[opCode], opnd, O2S(elemPtr), + O2S(valuePtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%s %u \"%.30s\" <- \"%.30s\" => ", + opName[opCode], opnd, O2S(elemPtr), O2S(valuePtr)), + value2Ptr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); + } + ADJUST_PC(pcAdjustment); + + case INST_STORE_ARRAY_STK: + { + Tcl_Obj *elemPtr; + + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = Tcl_ObjSetVar2(interp, namePtr, elemPtr, + valuePtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", + O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ", + O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + value2Ptr); + TclDecrRefCount(namePtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); + } + ADJUST_PC(1); + + case INST_STORE_STK: + valuePtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr, + TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ERROR: ", + O2S(namePtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ", + O2S(namePtr), O2S(valuePtr)), value2Ptr); + TclDecrRefCount(namePtr); + TclDecrRefCount(valuePtr); + ADJUST_PC(1); + + case INST_INCR_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr != &tclIntType) { + result = tclIntType.setFromAnyProc(interp, valuePtr); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("incrScalar1 %u (by %s) => ERROR converting increment amount to int: ", + opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + i = valuePtr->internalRep.longValue; + DECACHE_STACK_INFO(); + value2Ptr = TclIncrIndexedScalar(interp, opnd, i); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ERROR: ", + opnd, i), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ", opnd, i), + value2Ptr); + TclDecrRefCount(valuePtr); + ADJUST_PC(2); + + case INST_INCR_SCALAR_STK: + case INST_INCR_STK: + valuePtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + if (valuePtr->typePtr != &tclIntType) { + result = tclIntType.setFromAnyProc(interp, valuePtr); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%s \"%.30s\" (by %s) => ERROR converting increment amount to int: ", + opName[opCode], O2S(namePtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + i = valuePtr->internalRep.longValue; + DECACHE_STACK_INFO(); + value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i, + /*part1NotParsed*/ (opCode == INST_INCR_STK)); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ERROR: ", + opName[opCode], O2S(namePtr), i), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ", + opName[opCode], O2S(namePtr), i), value2Ptr); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); + ADJUST_PC(1); + + case INST_INCR_ARRAY1: + { + Tcl_Obj *elemPtr; + + opnd = TclGetUInt1AtPtr(pc+1); + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + if (valuePtr->typePtr != &tclIntType) { + result = tclIntType.setFromAnyProc(interp, valuePtr); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", + opnd, O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + i = valuePtr->internalRep.longValue; + DECACHE_STACK_INFO(); + value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, + elemPtr, i); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ERROR: ", + opnd, O2S(elemPtr), i), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ", + opnd, O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + } + ADJUST_PC(2); + + case INST_INCR_ARRAY_STK: + { + Tcl_Obj *elemPtr; + + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + if (valuePtr->typePtr != &tclIntType) { + result = tclIntType.setFromAnyProc(interp, valuePtr); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", + O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + i = valuePtr->internalRep.longValue; + DECACHE_STACK_INFO(); + value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i, + /*part1NotParsed*/ 0); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ERROR: ", + O2S(namePtr), O2S(elemPtr), i), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ", + O2S(namePtr), O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + } + ADJUST_PC(1); + + case INST_INCR_SCALAR1_IMM: + opnd = TclGetUInt1AtPtr(pc+1); + i = TclGetInt1AtPtr(pc+2); + DECACHE_STACK_INFO(); + value2Ptr = TclIncrIndexedScalar(interp, opnd, i); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ERROR: ", + opnd, i), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ", opnd, i), + value2Ptr); + ADJUST_PC(3); + + case INST_INCR_SCALAR_STK_IMM: + case INST_INCR_STK_IMM: + namePtr = POP_OBJECT(); + i = TclGetInt1AtPtr(pc+1); + DECACHE_STACK_INFO(); + value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i, + /*part1NotParsed*/ (opCode == INST_INCR_STK_IMM)); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ERROR: ", + opName[opCode], O2S(namePtr), i), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + Tcl_DecrRefCount(namePtr); + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ", + opName[opCode], O2S(namePtr), i), value2Ptr); + TclDecrRefCount(namePtr); + ADJUST_PC(2); + + case INST_INCR_ARRAY1_IMM: + { + Tcl_Obj *elemPtr; + + opnd = TclGetUInt1AtPtr(pc+1); + i = TclGetInt1AtPtr(pc+2); + elemPtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, + elemPtr, i); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ERROR: ", + opnd, O2S(elemPtr), i), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ", + opnd, O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(elemPtr); + } + ADJUST_PC(3); + + case INST_INCR_ARRAY_STK_IMM: + { + Tcl_Obj *elemPtr; + + i = TclGetInt1AtPtr(pc+1); + elemPtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i, + /*part1NotParsed*/ 0); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ERROR: ", + O2S(namePtr), O2S(elemPtr), i), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ", + O2S(namePtr), O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + } + ADJUST_PC(2); + + case INST_JUMP1: + opnd = TclGetInt1AtPtr(pc+1); + TRACE(("jump1 %d => new pc %u\n", opnd, + (unsigned int)(pc + opnd - codePtr->codeStart))); + ADJUST_PC(opnd); + + case INST_JUMP4: + opnd = TclGetInt4AtPtr(pc+1); + TRACE(("jump4 %d => new pc %u\n", opnd, + (unsigned int)(pc + opnd - codePtr->codeStart))); + ADJUST_PC(opnd); + + case INST_JUMP_TRUE4: + opnd = TclGetInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doJumpTrue; + + case INST_JUMP_TRUE1: + opnd = TclGetInt1AtPtr(pc+1); + pcAdjustment = 2; + + doJumpTrue: + { + int b; + + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr == &tclIntType) { + b = (valuePtr->internalRep.longValue != 0); + } else if (valuePtr->typePtr == &tclDoubleType) { + b = (valuePtr->internalRep.doubleValue != 0.0); + } else { + result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode], + opnd), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + if (b) { + TRACE(("%s %d => %.20s true, new pc %u\n", + opName[opCode], opnd, O2S(valuePtr), + (unsigned int)(pc+opnd - codePtr->codeStart))); + TclDecrRefCount(valuePtr); + ADJUST_PC(opnd); + } else { + TRACE(("%s %d => %.20s false\n", opName[opCode], opnd, + O2S(valuePtr))); + TclDecrRefCount(valuePtr); + ADJUST_PC(pcAdjustment); + } + } + + case INST_JUMP_FALSE4: + opnd = TclGetInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doJumpFalse; + + case INST_JUMP_FALSE1: + opnd = TclGetInt1AtPtr(pc+1); + pcAdjustment = 2; + + doJumpFalse: + { + int b; + + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr == &tclIntType) { + b = (valuePtr->internalRep.longValue != 0); + } else if (valuePtr->typePtr == &tclDoubleType) { + b = (valuePtr->internalRep.doubleValue != 0.0); + } else { + result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode], + opnd), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + if (b) { + TRACE(("%s %d => %.20s true\n", opName[opCode], opnd, + O2S(valuePtr))); + TclDecrRefCount(valuePtr); + ADJUST_PC(pcAdjustment); + } else { + TRACE(("%s %d => %.20s false, new pc %u\n", + opName[opCode], opnd, O2S(valuePtr), + (unsigned int)(pc + opnd - codePtr->codeStart))); + TclDecrRefCount(valuePtr); + ADJUST_PC(opnd); + } + } + + case INST_LOR: + case INST_LAND: + { + /* + * Operands must be boolean or numeric. No int->double + * conversions are performed. + */ + + int i1, i2; + int iResult; + char *s; + Tcl_ObjType *t1Ptr, *t2Ptr; + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + t1Ptr = valuePtr->typePtr; + t2Ptr = value2Ptr->typePtr; + + if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) { + i1 = (valuePtr->internalRep.longValue != 0); + } else if (t1Ptr == &tclDoubleType) { + i1 = (valuePtr->internalRep.doubleValue != 0.0); + } else { /* FAILS IF NULL STRING REP */ + s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + i1 = (i != 0); + } else { + result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, + valuePtr, &i1); + i1 = (i1 != 0); + } + if (result != TCL_OK) { + TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", + opName[opCode], O2S(valuePtr), + (t1Ptr? t1Ptr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + } + + if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) { + i2 = (value2Ptr->internalRep.longValue != 0); + } else if (t2Ptr == &tclDoubleType) { + i2 = (value2Ptr->internalRep.doubleValue != 0.0); + } else { /* FAILS IF NULL STRING REP */ + s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + value2Ptr, &i); + i2 = (i != 0); + } else { + result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, + value2Ptr, &i2); + i2 = (i2 != 0); + } + if (result != TCL_OK) { + TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", + opName[opCode], O2S(value2Ptr), + (t2Ptr? t2Ptr->name : "null"))); + IllegalExprOperandType(interp, opCode, value2Ptr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + } + + /* + * Reuse the valuePtr object already on stack if possible. + */ + + if (opCode == INST_LOR) { + iResult = (i1 || i2); + } else { + iResult = (i1 && i2); + } + if (Tcl_IsShared(valuePtr)) { + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + TRACE(("%s %.20s %.20s => %d\n", opName[opCode], + O2S(valuePtr), O2S(value2Ptr), iResult)); + TclDecrRefCount(valuePtr); + } else { /* reuse the valuePtr object */ + TRACE(("%s %.20s %.20s => %d\n", + opName[opCode], /* NB: stack top is off by 1 */ + O2S(valuePtr), O2S(value2Ptr), iResult)); + Tcl_SetLongObj(valuePtr, iResult); + ++stackTop; /* valuePtr now on stk top has right r.c. */ + } + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_GT: + case INST_LE: + case INST_GE: + { + /* + * Any type is allowed but the two operands must have the + * same type. We will compute value op value2. + */ + + Tcl_ObjType *t1Ptr, *t2Ptr; + char *s1 = NULL; /* Init. avoids compiler warning. */ + char *s2 = NULL; /* Init. avoids compiler warning. */ + long i2 = 0; /* Init. avoids compiler warning. */ + double d1 = 0.0; /* Init. avoids compiler warning. */ + double d2 = 0.0; /* Init. avoids compiler warning. */ + long iResult = 0; /* Init. avoids compiler warning. */ + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + t1Ptr = valuePtr->typePtr; + t2Ptr = value2Ptr->typePtr; + + if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) { + s1 = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s1)) { /* FAILS IF NULLS */ + (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + } else { + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d1); + } + t1Ptr = valuePtr->typePtr; + } + if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) { + s2 = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s2)) { /* FAILS IF NULLS */ + (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, + value2Ptr, &i2); + } else { + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + value2Ptr, &d2); + } + t2Ptr = value2Ptr->typePtr; + } + + if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) + || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) { + /* + * One operand is not numeric. Compare as strings. + * THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS. + */ + int cmpValue; + s1 = TclGetStringFromObj(valuePtr, &length); + s2 = TclGetStringFromObj(value2Ptr, &length); + cmpValue = strcmp(s1, s2); + switch (opCode) { + case INST_EQ: + iResult = (cmpValue == 0); + break; + case INST_NEQ: + iResult = (cmpValue != 0); + break; + case INST_LT: + iResult = (cmpValue < 0); + break; + case INST_GT: + iResult = (cmpValue > 0); + break; + case INST_LE: + iResult = (cmpValue <= 0); + break; + case INST_GE: + iResult = (cmpValue >= 0); + break; + } + } else if ((t1Ptr == &tclDoubleType) + || (t2Ptr == &tclDoubleType)) { + /* + * Compare as doubles. + */ + if (t1Ptr == &tclDoubleType) { + d1 = valuePtr->internalRep.doubleValue; + if (t2Ptr == &tclIntType) { + d2 = value2Ptr->internalRep.longValue; + } else { + d2 = value2Ptr->internalRep.doubleValue; + } + } else { /* t1Ptr is int, t2Ptr is double */ + d1 = valuePtr->internalRep.longValue; + d2 = value2Ptr->internalRep.doubleValue; + } + switch (opCode) { + case INST_EQ: + iResult = d1 == d2; + break; + case INST_NEQ: + iResult = d1 != d2; + break; + case INST_LT: + iResult = d1 < d2; + break; + case INST_GT: + iResult = d1 > d2; + break; + case INST_LE: + iResult = d1 <= d2; + break; + case INST_GE: + iResult = d1 >= d2; + break; + } + } else { + /* + * Compare as ints. + */ + i = valuePtr->internalRep.longValue; + i2 = value2Ptr->internalRep.longValue; + switch (opCode) { + case INST_EQ: + iResult = i == i2; + break; + case INST_NEQ: + iResult = i != i2; + break; + case INST_LT: + iResult = i < i2; + break; + case INST_GT: + iResult = i > i2; + break; + case INST_LE: + iResult = i <= i2; + break; + case INST_GE: + iResult = i >= i2; + break; + } + } + + /* + * Reuse the valuePtr object already on stack if possible. + */ + + if (Tcl_IsShared(valuePtr)) { + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + TRACE(("%s %.20s %.20s => %ld\n", opName[opCode], + O2S(valuePtr), O2S(value2Ptr), iResult)); + TclDecrRefCount(valuePtr); + } else { /* reuse the valuePtr object */ + TRACE(("%s %.20s %.20s => %ld\n", + opName[opCode], /* NB: stack top is off by 1 */ + O2S(valuePtr), O2S(value2Ptr), iResult)); + Tcl_SetLongObj(valuePtr, iResult); + ++stackTop; /* valuePtr now on stk top has right r.c. */ + } + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + { + /* + * Only integers are allowed. We compute value op value2. + */ + + long i2, rem, negative; + long iResult = 0; /* Init. avoids compiler warning. */ + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else { /* try to convert to int */ + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + if (result != TCL_OK) { + TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n", + opName[opCode], O2S(valuePtr), O2S(value2Ptr), + (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + } + if (value2Ptr->typePtr == &tclIntType) { + i2 = value2Ptr->internalRep.longValue; + } else { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + value2Ptr, &i2); + if (result != TCL_OK) { + TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n", + opName[opCode], O2S(valuePtr), O2S(value2Ptr), + (value2Ptr->typePtr? + value2Ptr->typePtr->name : "null"))); + IllegalExprOperandType(interp, opCode, value2Ptr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + } + + switch (opCode) { + case INST_MOD: + /* + * This code is tricky: C doesn't guarantee much about + * the quotient or remainder, but Tcl does. The + * remainder always has the same sign as the divisor and + * a smaller absolute value. + */ + if (i2 == 0) { + TRACE(("mod %ld %ld => DIVIDE BY ZERO\n", i, i2)); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto divideByZero; + } + negative = 0; + if (i2 < 0) { + i2 = -i2; + i = -i; + negative = 1; + } + rem = i % i2; + if (rem < 0) { + rem += i2; + } + if (negative) { + rem = -rem; + } + iResult = rem; + break; + case INST_LSHIFT: + iResult = i << i2; + break; + case INST_RSHIFT: + /* + * 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 (i < 0) { + iResult = ~((~i) >> i2); + } else { + iResult = i >> i2; + } + break; + case INST_BITOR: + iResult = i | i2; + break; + case INST_BITXOR: + iResult = i ^ i2; + break; + case INST_BITAND: + iResult = i & i2; + break; + } + + /* + * Reuse the valuePtr object already on stack if possible. + */ + + if (Tcl_IsShared(valuePtr)) { + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2, + iResult)); + TclDecrRefCount(valuePtr); + } else { /* reuse the valuePtr object */ + TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2, + iResult)); /* NB: stack top is off by 1 */ + Tcl_SetLongObj(valuePtr, iResult); + ++stackTop; /* valuePtr now on stk top has right r.c. */ + } + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + + case INST_ADD: + case INST_SUB: + case INST_MULT: + case INST_DIV: + { + /* + * Operands must be numeric and ints get converted to floats + * if necessary. We compute value op value2. + */ + + Tcl_ObjType *t1Ptr, *t2Ptr; + long i2, quot, rem; + double d1, d2; + long iResult = 0; /* Init. avoids compiler warning. */ + double dResult = 0.0; /* Init. avoids compiler warning. */ + int doDouble = 0; /* 1 if doing floating arithmetic */ + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + t1Ptr = valuePtr->typePtr; + t2Ptr = value2Ptr->typePtr; + + if (t1Ptr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (t1Ptr == &tclDoubleType) { + d1 = valuePtr->internalRep.doubleValue; + } else { /* try to convert; FAILS IF NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d1); + } + if (result != TCL_OK) { + TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n", + opName[opCode], s, O2S(value2Ptr), + (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + t1Ptr = valuePtr->typePtr; + } + + if (t2Ptr == &tclIntType) { + i2 = value2Ptr->internalRep.longValue; + } else if (t2Ptr == &tclDoubleType) { + d2 = value2Ptr->internalRep.doubleValue; + } else { /* try to convert; FAILS IF NULLS */ + char *s = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + value2Ptr, &i2); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + value2Ptr, &d2); + } + if (result != TCL_OK) { + TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n", + opName[opCode], O2S(valuePtr), s, + (value2Ptr->typePtr? + value2Ptr->typePtr->name : "null"))); + IllegalExprOperandType(interp, opCode, value2Ptr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + t2Ptr = value2Ptr->typePtr; + } + + if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) { + /* + * Do double arithmetic. + */ + doDouble = 1; + if (t1Ptr == &tclIntType) { + d1 = i; /* promote value 1 to double */ + } else if (t2Ptr == &tclIntType) { + d2 = i2; /* promote value 2 to double */ + } + switch (opCode) { + case INST_ADD: + dResult = d1 + d2; + break; + case INST_SUB: + dResult = d1 - d2; + break; + case INST_MULT: + dResult = d1 * d2; + break; + case INST_DIV: + if (d2 == 0.0) { + TRACE(("div %.6g %.6g => DIVIDE BY ZERO\n", + d1, d2)); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto divideByZero; + } + dResult = d1 / d2; + break; + } + + /* + * Check now for IEEE floating-point error. + */ + + if (IS_NAN(dResult) || IS_INF(dResult)) { + TRACE(("%s %.20s %.20s => IEEE FLOATING PT ERROR\n", + opName[opCode], O2S(valuePtr), O2S(value2Ptr))); + TclExprFloatError(interp, dResult); + result = TCL_ERROR; + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + } else { + /* + * Do integer arithmetic. + */ + switch (opCode) { + case INST_ADD: + iResult = i + i2; + break; + case INST_SUB: + iResult = i - i2; + break; + case INST_MULT: + iResult = i * i2; + break; + case INST_DIV: + /* + * This code is tricky: C doesn't guarantee much + * about the quotient or remainder, but Tcl does. + * The remainder always has the same sign as the + * divisor and a smaller absolute value. + */ + if (i2 == 0) { + TRACE(("div %ld %ld => DIVIDE BY ZERO\n", + i, i2)); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto divideByZero; + } + if (i2 < 0) { + i2 = -i2; + i = -i; + } + quot = i / i2; + rem = i % i2; + if (rem < 0) { + quot -= 1; + } + iResult = quot; + break; + } + } + + /* + * Reuse the valuePtr object already on stack if possible. + */ + + if (Tcl_IsShared(valuePtr)) { + if (doDouble) { + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode], + d1, d2, dResult)); + } else { + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + TRACE(("%s %ld %ld => %ld\n", opName[opCode], + i, i2, iResult)); + } + TclDecrRefCount(valuePtr); + } else { /* reuse the valuePtr object */ + if (doDouble) { /* NB: stack top is off by 1 */ + TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode], + d1, d2, dResult)); + Tcl_SetDoubleObj(valuePtr, dResult); + } else { + TRACE(("%s %ld %ld => %ld\n", opName[opCode], + i, i2, iResult)); + Tcl_SetLongObj(valuePtr, iResult); + } + ++stackTop; /* valuePtr now on stk top has right r.c. */ + } + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + + case INST_UPLUS: + { + /* + * Operand must be numeric. + */ + + double d; + Tcl_ObjType *tPtr; + + valuePtr = stackPtr[stackTop].o; + tPtr = valuePtr->typePtr; + if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d); + } + if (result != TCL_OK) { + TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", + opName[opCode], s, + (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + goto checkForCatch; + } + } + TRACE_WITH_OBJ(("uplus %s => ", O2S(valuePtr)), valuePtr); + } + ADJUST_PC(1); + + case INST_UMINUS: + case INST_LNOT: + { + /* + * The operand must be numeric. If the operand object is + * unshared modify it directly, otherwise create a copy to + * modify: this is "copy on write". free any old string + * representation since it is now invalid. + */ + + double d; + Tcl_ObjType *tPtr; + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d); + } + if (result != TCL_OK) { + TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s\n", + opName[opCode], s, + (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + tPtr = valuePtr->typePtr; + } + + if (Tcl_IsShared(valuePtr)) { + /* + * Create a new object. + */ + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + objPtr = Tcl_NewLongObj( + (opCode == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i), + objPtr); /* NB: stack top is off by 1 */ + } else { + d = valuePtr->internalRep.doubleValue; + if (opCode == INST_UMINUS) { + objPtr = Tcl_NewDoubleObj(-d); + } else { + /* + * Should be able to use "!d", but apparently + * some compilers can't handle it. + */ + objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); + } + TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d), + objPtr); /* NB: stack top is off by 1 */ + } + PUSH_OBJECT(objPtr); + TclDecrRefCount(valuePtr); + } else { + /* + * valuePtr is unshared. Modify it directly. + */ + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + Tcl_SetLongObj(valuePtr, + (opCode == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i), + valuePtr); /* NB: stack top is off by 1 */ + } else { + d = valuePtr->internalRep.doubleValue; + if (opCode == INST_UMINUS) { + Tcl_SetDoubleObj(valuePtr, -d); + } else { + /* + * Should be able to use "!d", but apparently + * some compilers can't handle it. + */ + Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0); + } + TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d), + valuePtr); /* NB: stack top is off by 1 */ + } + ++stackTop; /* valuePtr now on stk top has right r.c. */ + } + } + ADJUST_PC(1); + + case INST_BITNOT: + { + /* + * The operand must be an integer. If the operand object is + * unshared modify it directly, otherwise modify a copy. + * Free any old string representation since it is now + * invalid. + */ + + Tcl_ObjType *tPtr; + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + if (tPtr != &tclIntType) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + if (result != TCL_OK) { /* try to convert to double */ + TRACE(("bitnot \"%.20s\" => ILLEGAL TYPE %s\n", + O2S(valuePtr), (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + + i = valuePtr->internalRep.longValue; + if (Tcl_IsShared(valuePtr)) { + PUSH_OBJECT(Tcl_NewLongObj(~i)); + TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i)); + TclDecrRefCount(valuePtr); + } else { + /* + * valuePtr is unshared. Modify it directly. + */ + Tcl_SetLongObj(valuePtr, ~i); + ++stackTop; /* valuePtr now on stk top has right r.c. */ + TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i)); + } + } + ADJUST_PC(1); + + case INST_CALL_BUILTIN_FUNC1: + opnd = TclGetUInt1AtPtr(pc+1); + { + /* + * Call one of the built-in Tcl math functions. + */ + + BuiltinFunc *mathFuncPtr; + + if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { + TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); + panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); + } + mathFuncPtr = &(builtinFuncTable[opnd]); + DECACHE_STACK_INFO(); + tcl_MathInProgress++; + result = (*mathFuncPtr->proc)(interp, eePtr, + mathFuncPtr->clientData); + tcl_MathInProgress--; + CACHE_STACK_INFO(); + if (result != TCL_OK) { + goto checkForCatch; + } + TRACE_WITH_OBJ(("callBuiltinFunc1 %d => ", opnd), + stackPtr[stackTop].o); + } + ADJUST_PC(2); + + case INST_CALL_FUNC1: + opnd = TclGetUInt1AtPtr(pc+1); + { + /* + * Call a non-builtin Tcl math function previously + * registered by a call to Tcl_CreateMathFunc. + */ + + int objc = opnd; /* Number of arguments. The function name + * is the 0-th argument. */ + Tcl_Obj **objv; /* The array of arguments. The function + * name is objv[0]. */ + + objv = &(stackPtr[stackTop - (objc-1)].o); /* "objv[0]" */ + DECACHE_STACK_INFO(); + tcl_MathInProgress++; + result = ExprCallMathFunc(interp, eePtr, objc, objv); + tcl_MathInProgress--; + CACHE_STACK_INFO(); + if (result != TCL_OK) { + goto checkForCatch; + } + TRACE_WITH_OBJ(("callFunc1 %d => ", objc), + stackPtr[stackTop].o); + ADJUST_PC(2); + } + + case INST_TRY_CVT_TO_NUMERIC: + { + /* + * Try to convert the topmost stack object to an int or + * double object. This is done in order to support Tcl's + * policy of interpreting operands if at all possible as + * first integers, else floating-point numbers. + */ + + double d; + char *s; + Tcl_ObjType *tPtr; + int converted, shared; + + valuePtr = stackPtr[stackTop].o; + tPtr = valuePtr->typePtr; + converted = 0; + if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { + s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d); + } + if (result == TCL_OK) { + converted = 1; + } + result = TCL_OK; /* reset the result variable */ + tPtr = valuePtr->typePtr; + } + + /* + * Ensure that the topmost stack object, if numeric, has a + * string rep the same as the formatted version of its + * internal rep. This is used, e.g., to make sure that "expr + * {0001}" yields "1", not "0001". We implement this by + * _discarding_ the string rep since we know it will be + * regenerated, if needed later, by formatting the internal + * rep's value. Also check if there has been an IEEE + * floating point error. + */ + + if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) { + shared = 0; + if (Tcl_IsShared(valuePtr)) { + shared = 1; + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + objPtr = Tcl_NewLongObj(i); + } else { + d = valuePtr->internalRep.doubleValue; + objPtr = Tcl_NewDoubleObj(d); + } + Tcl_IncrRefCount(objPtr); + TclDecrRefCount(valuePtr); + valuePtr = objPtr; + tPtr = valuePtr->typePtr; + } else { + Tcl_InvalidateStringRep(valuePtr); + } + stackPtr[stackTop].o = valuePtr; + + if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + if (IS_NAN(d) || IS_INF(d)) { + TRACE(("tryCvtToNumeric \"%.20s\" => IEEE FLOATING PT ERROR\n", + O2S(valuePtr))); + TclExprFloatError(interp, d); + result = TCL_ERROR; + goto checkForCatch; + } + } + shared = shared; /* lint, shared not used. */ + converted = converted; /* lint, converted not used. */ + TRACE(("tryCvtToNumeric \"%.20s\" => numeric, %s, %s\n", + O2S(valuePtr), + (converted? "converted" : "not converted"), + (shared? "shared" : "not shared"))); + } else { + TRACE(("tryCvtToNumeric \"%.20s\" => not numeric\n", + O2S(valuePtr))); + } + } + ADJUST_PC(1); + + case INST_BREAK: + /* + * First reset the interpreter's result. Then find the closest + * enclosing loop or catch exception range, if any. If a loop is + * found, terminate its execution. If the closest is a catch + * exception range, jump to its catchOffset. If no enclosing + * range is found, stop execution and return TCL_BREAK. + */ + + Tcl_ResetResult(interp); + rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, + codePtr); + if (rangePtr == NULL) { + TRACE(("break => no encl. loop or catch, returning TCL_BREAK\n")); + result = TCL_BREAK; + goto abnormalReturn; /* no catch exists to check */ + } + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + result = TCL_OK; + TRACE(("break => range at %d, new pc %d\n", + rangePtr->codeOffset, rangePtr->breakOffset)); + break; + case CATCH_EXCEPTION_RANGE: + result = TCL_BREAK; + TRACE(("break => ...\n")); + goto processCatch; /* it will use rangePtr */ + default: + panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); + } + pc = (codePtr->codeStart + rangePtr->breakOffset); + continue; /* restart outer instruction loop at pc */ + + case INST_CONTINUE: + /* + * Find the closest enclosing loop or catch exception range, + * if any. If a loop is found, skip to its next iteration. + * If the closest is a catch exception range, jump to its + * catchOffset. If no enclosing range is found, stop + * execution and return TCL_CONTINUE. + */ + + Tcl_ResetResult(interp); + rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, + codePtr); + if (rangePtr == NULL) { + TRACE(("continue => no encl. loop or catch, returning TCL_CONTINUE\n")); + result = TCL_CONTINUE; + goto abnormalReturn; + } + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + if (rangePtr->continueOffset == -1) { + TRACE(("continue => loop w/o continue, checking for catch\n")); + goto checkForCatch; + } else { + result = TCL_OK; + TRACE(("continue => range at %d, new pc %d\n", + rangePtr->codeOffset, rangePtr->continueOffset)); + } + break; + case CATCH_EXCEPTION_RANGE: + result = TCL_CONTINUE; + TRACE(("continue => ...\n")); + goto processCatch; /* it will use rangePtr */ + default: + panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); + } + pc = (codePtr->codeStart + rangePtr->continueOffset); + continue; /* restart outer instruction loop at pc */ + + case INST_FOREACH_START4: + opnd = TclGetUInt4AtPtr(pc+1); + { + /* + * Initialize the temporary local var that holds the count + * of the number of iterations of the loop body to -1. + */ + + ForeachInfo *infoPtr = (ForeachInfo *) + codePtr->auxDataArrayPtr[opnd].clientData; + int iterTmpIndex = infoPtr->loopIterNumTmp; + CallFrame *varFramePtr = iPtr->varFramePtr; + Var *compiledLocals = varFramePtr->compiledLocals; + Var *iterVarPtr; + Tcl_Obj *oldValuePtr; + + iterVarPtr = &(compiledLocals[iterTmpIndex]); + oldValuePtr = iterVarPtr->value.objPtr; + if (oldValuePtr == NULL) { + iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); + Tcl_IncrRefCount(iterVarPtr->value.objPtr); + } else { + Tcl_SetLongObj(oldValuePtr, -1); + } + TclSetVarScalar(iterVarPtr); + TclClearVarUndefined(iterVarPtr); + TRACE(("foreach_start4 %u => loop iter count temp %d\n", + opnd, iterTmpIndex)); + } + ADJUST_PC(5); + + case INST_FOREACH_STEP4: + opnd = TclGetUInt4AtPtr(pc+1); + { + /* + * "Step" a foreach loop (i.e., begin its next iteration) by + * assigning the next value list element to each loop var. + */ + + ForeachInfo *infoPtr = (ForeachInfo *) + codePtr->auxDataArrayPtr[opnd].clientData; + ForeachVarList *varListPtr; + int numLists = infoPtr->numLists; + int iterTmpIndex = infoPtr->loopIterNumTmp; + CallFrame *varFramePtr = iPtr->varFramePtr; + Var *compiledLocals = varFramePtr->compiledLocals; + int iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, j; + Tcl_Obj *listPtr, *elemPtr, *oldValuePtr; + List *listRepPtr; + Var *iterVarPtr, *listVarPtr; + int continueLoop = 0; + + /* + * Increment the temp holding the loop iteration number. + */ + + iterVarPtr = &(compiledLocals[iterTmpIndex]); + oldValuePtr = iterVarPtr->value.objPtr; + iterNum = (oldValuePtr->internalRep.longValue + 1); + Tcl_SetLongObj(oldValuePtr, iterNum); + + /* + * Check whether all value lists are exhausted and we should + * stop the loop. + */ + + listTmpIndex = infoPtr->firstListTmp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listVarPtr = &(compiledLocals[listTmpIndex]); + listPtr = listVarPtr->value.objPtr; + result = Tcl_ListObjLength(interp, listPtr, &listLen); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("foreach_step4 %u => ERROR converting list %ld, \"%s\": ", + opnd, i, O2S(listPtr)), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } + if (listLen > (iterNum * numVars)) { + continueLoop = 1; + } + listTmpIndex++; + } + + /* + * If some var in some var list still has a remaining list + * element iterate one more time. Assign to var the next + * element from its value list. We already checked above + * that each list temp holds a valid list object. + */ + + if (continueLoop) { + listTmpIndex = infoPtr->firstListTmp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listVarPtr = &(compiledLocals[listTmpIndex]); + listPtr = listVarPtr->value.objPtr; + listRepPtr = (List *) + listPtr->internalRep.otherValuePtr; + listLen = listRepPtr->elemCount; + + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + int setEmptyStr = 0; + if (valIndex >= listLen) { + setEmptyStr = 1; + elemPtr = Tcl_NewObj(); + } else { + elemPtr = listRepPtr->elements[valIndex]; + } + + varIndex = varListPtr->varIndexes[j]; + DECACHE_STACK_INFO(); + value2Ptr = TclSetIndexedScalar(interp, + varIndex, elemPtr, /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("foreach_step4 %u => ERROR init. index temp %d: ", + opnd, varIndex), + Tcl_GetObjResult(interp)); + if (setEmptyStr) { + Tcl_DecrRefCount(elemPtr); /* unneeded */ + } + result = TCL_ERROR; + goto checkForCatch; + } + valIndex++; + } + listTmpIndex++; + } + } + + /* + * Now push a "1" object if at least one value list had a + * remaining element and the loop should continue. + * Otherwise push "0". + */ + + PUSH_OBJECT(Tcl_NewLongObj(continueLoop)); + TRACE(("foreach_step4 %u => %d lists, iter %d, %s loop\n", + opnd, numLists, iterNum, + (continueLoop? "continue" : "exit"))); + } + ADJUST_PC(5); + + case INST_BEGIN_CATCH4: + /* + * Record start of the catch command with exception range index + * equal to the operand. Push the current stack depth onto the + * special catch stack. + */ + catchStackPtr[++catchTop] = stackTop; + TRACE(("beginCatch4 %u => catchTop=%d, stackTop=%d\n", + TclGetUInt4AtPtr(pc+1), catchTop, stackTop)); + ADJUST_PC(5); + + case INST_END_CATCH: + catchTop--; + result = TCL_OK; + TRACE(("endCatch => catchTop=%d\n", catchTop)); + ADJUST_PC(1); + + case INST_PUSH_RESULT: + PUSH_OBJECT(Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("pushResult => "), Tcl_GetObjResult(interp)); + ADJUST_PC(1); + + case INST_PUSH_RETURN_CODE: + PUSH_OBJECT(Tcl_NewLongObj(result)); + TRACE(("pushReturnCode => %u\n", result)); + ADJUST_PC(1); + + default: + TRACE(("UNRECOGNIZED INSTRUCTION %u\n", opCode)); + panic("TclExecuteByteCode: unrecognized opCode %u", opCode); + } /* end of switch on opCode */ + + /* + * Division by zero in an expression. Control only reaches this + * point by "goto divideByZero". + */ + + divideByZero: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1); + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", + (char *) NULL); + result = TCL_ERROR; + + /* + * Execution has generated an "exception" such as TCL_ERROR. If the + * exception is an error, record information about what was being + * executed when the error occurred. Find the closest enclosing + * catch range, if any. If no enclosing catch range is found, stop + * execution and return the "exception" code. + */ + + checkForCatch: + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + RecordTracebackInfo(interp, pc, codePtr); + } + rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr); + if (rangePtr == NULL) { + TRACE((" ... no enclosing catch, returning %s\n", + StringForResultCode(result))); + goto abnormalReturn; + } + + /* + * A catch exception range (rangePtr) was found to handle an + * "exception". It was found either by checkForCatch just above or + * by an instruction during break, continue, or error processing. + * Jump to its catchOffset after unwinding the operand stack to + * the depth it had when starting to execute the range's catch + * command. + */ + + processCatch: + while (stackTop > catchStackPtr[catchTop]) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + TRACE((" ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", + rangePtr->codeOffset, catchTop, catchStackPtr[catchTop], + (unsigned int)(rangePtr->catchOffset))); + pc = (codePtr->codeStart + rangePtr->catchOffset); + continue; /* restart the execution loop at pc */ + } /* end of infinite loop dispatching on instructions */ + + /* + * Abnormal return code. Restore the stack to state it had when starting + * to execute the ByteCode. + */ + + abnormalReturn: + while (stackTop > initStackTop) { + valuePtr = POP_OBJECT(); + Tcl_DecrRefCount(valuePtr); + } + + /* + * Free the catch stack array if malloc'ed storage was used. + */ + + done: + if (catchStackPtr != catchStackStorage) { + ckfree((char *) catchStackPtr); + } + eePtr->stackTop = initStackTop; + return result; +#undef STATIC_CATCH_STACK_SIZE +} + +/* + *---------------------------------------------------------------------- + * + * PrintByteCodeInfo -- + * + * This procedure prints a summary about a bytecode object to stdout. + * It is called by TclExecuteByteCode when starting to execute the + * bytecode object if tclTraceExec has the value 2 or more. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PrintByteCodeInfo(codePtr) + register ByteCode *codePtr; /* The bytecode whose summary is printed + * to stdout. */ +{ + Proc *procPtr = codePtr->procPtr; + int numCmds = codePtr->numCommands; + int numObjs = codePtr->numObjects; + int objBytes, i; + + objBytes = (numObjs * sizeof(Tcl_Obj)); + for (i = 0; i < numObjs; i++) { + Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i]; + if (litObjPtr->bytes != NULL) { + objBytes += litObjPtr->length; + } + } + + fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n", + (unsigned int) codePtr, codePtr->refCount, + codePtr->compileEpoch, (unsigned int) codePtr->iPtr, + codePtr->iPtr->compileEpoch); + + fprintf(stdout, " Source: "); + TclPrintSource(stdout, codePtr->source, 70); + + fprintf(stdout, "\n Cmds %d, chars %d, inst %u, objs %u, aux %d, stk depth %u, code/src %.2fn", + numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs, + codePtr->numAuxDataItems, codePtr->maxStackDepth, + (codePtr->numSrcChars? + ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0)); + + fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n", + codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes, + objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)), + (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); + + if (procPtr != NULL) { + fprintf(stdout, + " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n", + (unsigned int) procPtr, procPtr->refCount, + procPtr->numArgs, procPtr->numCompiledLocals); + } +} + +/* + *---------------------------------------------------------------------- + * + * ValidatePcAndStackTop -- + * + * This procedure is called by TclExecuteByteCode when debugging to + * verify that the program counter and stack top are valid during + * execution. + * + * Results: + * None. + * + * Side effects: + * Prints a message to stderr and panics if either the pc or stack + * top are invalid. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_COMPILE_DEBUG +static void +ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound) + register ByteCode *codePtr; /* The bytecode whose summary is printed + * to stdout. */ + unsigned char *pc; /* Points to first byte of a bytecode + * instruction. The program counter. */ + int stackTop; /* Current stack top. Must be between + * stackLowerBound and stackUpperBound + * (inclusive). */ + int stackLowerBound; /* Smallest legal value for stackTop. */ + int stackUpperBound; /* Greatest legal value for stackTop. */ +{ + unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart); + unsigned int codeStart = (unsigned int) codePtr->codeStart; + unsigned int codeEnd = (unsigned int) + (codePtr->codeStart + codePtr->numCodeBytes); + unsigned char opCode = *pc; + + if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) { + fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n", + (unsigned int) pc); + panic("TclExecuteByteCode execution failure: bad pc"); + } + if ((unsigned int) opCode > LAST_INST_OPCODE) { + fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", + (unsigned int) opCode, relativePc); + panic("TclExecuteByteCode execution failure: bad opcode"); + } + if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) { + int numChars; + char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + char *ellipsis = ""; + + fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode", + stackTop, relativePc); + if (cmd != NULL) { + if (numChars > 100) { + numChars = 100; + ellipsis = "..."; + } + fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd, + ellipsis); + } else { + fprintf(stderr, "\n"); + } + panic("TclExecuteByteCode execution failure: bad stack top"); + } +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * IllegalExprOperandType -- + * + * Used by TclExecuteByteCode to add an error message to errorInfo + * when an illegal operand type is detected by an expression + * instruction. The argument opCode holds the failing instruction's + * opcode and opndPtr holds the operand object in error. + * + * Results: + * None. + * + * Side effects: + * An error message is appended to errorInfo. + * + *---------------------------------------------------------------------- + */ + +static void +IllegalExprOperandType(interp, opCode, opndPtr) + Tcl_Interp *interp; /* Interpreter to which error information + * pertains. */ + unsigned int opCode; /* The instruction opcode being executed + * when the illegal type was found. */ + Tcl_Obj *opndPtr; /* Points to the operand holding the value + * with the illegal type. */ +{ + Tcl_ResetResult(interp); + if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't use empty string as operand of \"", + operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", + ((opndPtr->typePtr == &tclDoubleType) ? + "floating-point value" : "non-numeric string"), + " as operand of \"", operatorStrings[opCode - INST_LOR], + "\"", (char *) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * CallTraceProcedure -- + * + * Invokes a trace procedure registered with an interpreter. These + * procedures trace command execution. Currently this trace procedure + * is called with the address of the string-based Tcl_CmdProc for the + * command, not the Tcl_ObjCmdProc. + * + * Results: + * None. + * + * Side effects: + * Those side effects made by the trace procedure. + * + *---------------------------------------------------------------------- + */ + +static void +CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) + Tcl_Interp *interp; /* The current interpreter. */ + register Trace *tracePtr; /* Describes the trace procedure to call. */ + Command *cmdPtr; /* Points to command's Command struct. */ + char *command; /* Points to the first character of the + * command's source before substitutions. */ + int numChars; /* The number of characters in the + * command's source. */ + register int objc; /* Number of arguments for the command. */ + Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */ +{ + Interp *iPtr = (Interp *) interp; + register char **argv; + register int i; + int length; + char *p; + + /* + * Get the string rep from the objv argument objects and place their + * pointers in argv. First make sure argv is large enough to hold the + * objc args plus 1 extra word for the zero end-of-argv word. + * THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS. + */ + + argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetStringFromObj(objv[i], &length); + } + argv[objc] = 0; + + /* + * Copy the command characters into a new string. + */ + + p = (char *) ckalloc((unsigned) (numChars + 1)); + memcpy((VOID *) p, (VOID *) command, (size_t) numChars); + p[numChars] = '\0'; + + /* + * Call the trace procedure then free allocated storage. + */ + + (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, + p, cmdPtr->proc, cmdPtr->clientData, objc, argv); + + ckfree((char *) argv); + ckfree((char *) p); +} + +/* + *---------------------------------------------------------------------- + * + * RecordTracebackInfo -- + * + * Procedure called by TclExecuteByteCode to record information + * about what was being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Appends information about the command being executed to the + * "errorInfo" variable. Sets the errorLine field in the interpreter + * to the line number of that command. Sets the ERR_ALREADY_LOGGED + * bit in the interpreter's execution flags. + * + *---------------------------------------------------------------------- + */ + +static void +RecordTracebackInfo(interp, pc, codePtr) + Tcl_Interp *interp; /* The interpreter in which the error + * occurred. */ + unsigned char *pc; /* The program counter value where the error * occurred. This points to a bytecode + * instruction in codePtr's code. */ + ByteCode *codePtr; /* The bytecode sequence being executed. */ +{ + register Interp *iPtr = (Interp *) interp; + char *cmd, *ellipsis; + char buf[200]; + register char *p; + int numChars; + + /* + * Record the command in errorInfo (up to a certain number of + * characters, or up to the first newline). + */ + + iPtr->errorLine = 1; + cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + if (cmd != NULL) { + for (p = codePtr->source; p != cmd; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + for ( ; (isspace(UCHAR(*p)) || (*p == ';')); p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + ellipsis = ""; + if (numChars > 150) { + numChars = 150; + ellipsis = "..."; + } + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(buf, "\n while executing\n\"%.*s%s\"", + numChars, cmd, ellipsis); + } else { + sprintf(buf, "\n invoked from within\n\"%.*s%s\"", + numChars, cmd, ellipsis); + } + Tcl_AddObjErrorInfo(interp, buf, -1); + iPtr->flags |= ERR_ALREADY_LOGGED; + } +} + +/* + *---------------------------------------------------------------------- + * + * GetSrcInfoForPc -- + * + * Given a program counter value, finds the closest command in the + * bytecode code unit's CmdLocation array and returns information about + * that command's source: a pointer to its first byte and the number of + * characters. + * + * Results: + * If a command is found that encloses the program counter value, a + * pointer to the command's source is returned and the length of the + * source is stored at *lengthPtr. If multiple commands resulted in + * code at pc, information about the closest enclosing command is + * returned. If no matching command is found, NULL is returned and + * *lengthPtr is unchanged. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +GetSrcInfoForPc(pc, codePtr, lengthPtr) + unsigned char *pc; /* The program counter value for which to + * return the closest command's source info. + * This points to a bytecode instruction + * in codePtr's code. */ + ByteCode *codePtr; /* The bytecode sequence in which to look + * up the command source for the pc. */ + int *lengthPtr; /* If non-NULL, the location where the + * length of the command's source should be + * stored. If NULL, no length is stored. */ +{ + register int pcOffset = (pc - codePtr->codeStart); + int numCmds = codePtr->numCommands; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; + int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ + int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ + int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + + if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { + return NULL; + } + + /* + * Decode the code and source offset and length for each command. The + * closest enclosing command is the last one whose code started before + * pcOffset. + */ + + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + codeEnd = (codeOffset + codeLen - 1); + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + if (codeOffset > pcOffset) { /* best cmd already found */ + break; + } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */ + int dist = (pcOffset - codeOffset); + if (dist <= bestDist) { + bestDist = dist; + bestSrcOffset = srcOffset; + bestSrcLength = srcLen; + } + } + } + + if (bestDist == INT_MAX) { + return NULL; + } + + if (lengthPtr != NULL) { + *lengthPtr = bestSrcLength; + } + return (codePtr->source + bestSrcOffset); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetExceptionRangeForPc -- + * + * Procedure that given a program counter value, returns the closest + * enclosing ExceptionRange that matches the kind requested. + * + * Results: + * In the normal case, catchOnly is 0 (false) and this procedure + * returns a pointer to the most closely enclosing ExceptionRange + * structure regardless of whether it is a loop or catch exception + * range. This is appropriate when processing a TCL_BREAK or + * TCL_CONTINUE, which will be "handled" either by a loop exception + * range or a closer catch range. If catchOnly is nonzero (true), this + * procedure ignores loop exception ranges and returns a pointer to the + * closest catch range. If no matching ExceptionRange is found that + * encloses pc, a NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ExceptionRange * +TclGetExceptionRangeForPc(pc, catchOnly, codePtr) + unsigned char *pc; /* The program counter value for which to + * search for a closest enclosing exception + * range. This points to a bytecode + * instruction in codePtr's code. */ + int catchOnly; /* If 0, consider either loop or catch + * ExceptionRanges in search. Otherwise + * consider only catch ranges (and ignore + * any closer loop ranges). */ + ByteCode* codePtr; /* Points to the ByteCode in which to search + * for the enclosing ExceptionRange. */ +{ + ExceptionRange *rangeArrayPtr = codePtr->excRangeArrayPtr; + int numRanges = codePtr->numExcRanges; + register ExceptionRange *rangePtr; + int codeOffset = (pc - codePtr->codeStart); + register int i, level; + + for (level = codePtr->maxExcRangeDepth; level >= 0; level--) { + for (i = 0; i < numRanges; i++) { + rangePtr = &(rangeArrayPtr[i]); + if (rangePtr->nestingLevel == level) { + int start = rangePtr->codeOffset; + int end = (start + rangePtr->numCodeBytes); + if ((start <= codeOffset) && (codeOffset < end)) { + if ((!catchOnly) + || (rangePtr->type == CATCH_EXCEPTION_RANGE)) { + return rangePtr; + } + } + } + } + } + return 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 pushes an + * Tcl object holding the result. If it fails it returns TCL_ERROR + * and leaves an error message in the interpreter's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprUnaryFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Contains the address of a procedure that + * takes one double argument and returns a + * double result. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + double d, dResult; + long i; + int result = TCL_OK; + + double (*func) _ANSI_ARGS_((double)) = + (double (*)_ANSI_ARGS_((double))) clientData; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the function's argument from the evaluation stack. Convert it + * to a double if necessary. + */ + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + d = (double) valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + d = (double) valuePtr->internalRep.longValue; + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); + } + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + } + + errno = 0; + dResult = (*func)(d); + if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { + TclExprFloatError(interp, dResult); + result = TCL_ERROR; + goto done; + } + + /* + * Push a Tcl object holding the result. + */ + + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprBinaryFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Contains the address of a procedure that + * takes two double arguments and + * returns a double result. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr, *value2Ptr; + Tcl_ObjType *tPtr; + double d1, d2, dResult; + long i; + char *s; + int result = TCL_OK; + + double (*func) _ANSI_ARGS_((double, double)) + = (double (*)_ANSI_ARGS_((double, double))) clientData; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the function's two arguments from the evaluation stack. Convert + * them to doubles if necessary. + */ + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + + tPtr = valuePtr->typePtr; + if (tPtr == &tclIntType) { + d1 = (double) valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d1 = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + d1 = (double) valuePtr->internalRep.longValue; + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d1); + } + if (result != TCL_OK) { + badArg: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + } + + tPtr = value2Ptr->typePtr; + if (tPtr == &tclIntType) { + d2 = value2Ptr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d2 = value2Ptr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i); + d2 = (double) value2Ptr->internalRep.longValue; + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, value2Ptr, &d2); + } + if (result != TCL_OK) { + goto badArg; + } + } + + errno = 0; + dResult = (*func)(d1, d2); + if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { + TclExprFloatError(interp, dResult); + result = TCL_ERROR; + goto done; + } + + /* + * Push a Tcl object holding the result. + */ + + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprAbsFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + long i, iResult; + double d, dResult; + int result = TCL_OK; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); + } + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + tPtr = valuePtr->typePtr; + } + + /* + * Push a Tcl object with the result. + */ + + if (tPtr == &tclIntType) { + if (i < 0) { + iResult = -i; + if (iResult < 0) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent", -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else { + iResult = i; + } + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + } else { + if (d < 0.0) { + dResult = -d; + } else { + dResult = d; + } + if (IS_NAN(dResult) || IS_INF(dResult)) { + TclExprFloatError(interp, dResult); + result = TCL_ERROR; + goto done; + } + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + } + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprDoubleFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + double dResult; + long i; + int result = TCL_OK; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr == &tclIntType) { + dResult = (double) valuePtr->internalRep.longValue; + } else if (valuePtr->typePtr == &tclDoubleType) { + dResult = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + dResult = (double) valuePtr->internalRep.longValue; + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, + &dResult); + } + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + } + + /* + * Push a Tcl object with the result. + */ + + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprIntFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + long i = 0; /* Initialized to avoid compiler warning. */ + long iResult; + double d; + int result = TCL_OK; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); + } + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + tPtr = valuePtr->typePtr; + } + + /* + * Push a Tcl object with the result. + */ + + if (tPtr == &tclIntType) { + iResult = i; + } else { + if (d < 0.0) { + if (d < (double) (long) LONG_MIN) { + tooLarge: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent", -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else { + if (d > (double) LONG_MAX) { + goto tooLarge; + } + } + if (IS_NAN(d) || IS_INF(d)) { + TclExprFloatError(interp, d); + result = TCL_ERROR; + goto done; + } + iResult = (long) d; + } + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprRandFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + Interp *iPtr = (Interp *) interp; + double dResult; + int tmp; + + if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { + iPtr->flags |= RAND_SEED_INITIALIZED; + iPtr->randSeed = TclpGetClicks(); + } + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Generate the random number using the linear congruential + * generator defined by the following recurrence: + * seed = ( IA * seed ) mod IM + * where IA is 16807 and IM is (2^31) - 1. In order to avoid + * potential problems with integer overflow, the code uses + * additional constants IQ and IR such that + * IM = IA*IQ + IR + * For details on how this algorithm works, refer to the following + * papers: + * + * S.K. Park & K.W. Miller, "Random number generators: good ones + * are hard to find," Comm ACM 31(10):1192-1201, Oct 1988 + * + * W.H. Press & S.A. Teukolsky, "Portable random number + * generators," Computers in Physics 6(5):522-524, Sep/Oct 1992. + */ + +#define RAND_IA 16807 +#define RAND_IM 2147483647 +#define RAND_IQ 127773 +#define RAND_IR 2836 +#define RAND_MASK 123459876 + + if (iPtr->randSeed == 0) { + /* + * Don't allow a 0 seed, since it breaks the generator. Shift + * it to some other value. + */ + + iPtr->randSeed = 123459876; + } + tmp = iPtr->randSeed/RAND_IQ; + iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; + if (iPtr->randSeed < 0) { + iPtr->randSeed += RAND_IM; + } + + /* + * On 64-bit architectures we need to mask off the upper bits to + * ensure we only have a 32-bit range. The constant has the + * bizarre form below in order to make sure that it doesn't + * get sign-extended (the rules for sign extension are very + * concat, particularly on 64-bit machines). + */ + + iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf); + dResult = iPtr->randSeed * (1.0/RAND_IM); + + /* + * Push a Tcl object with the result. + */ + + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + DECACHE_STACK_INFO(); + return TCL_OK; +} + +static int +ExprRoundFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + long i = 0; /* Initialized to avoid compiler warning. */ + long iResult; + double d, temp; + int result = TCL_OK; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); + } + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + tPtr = valuePtr->typePtr; + } + + /* + * Push a Tcl object with the result. + */ + + if (tPtr == &tclIntType) { + iResult = i; + } else { + if (d < 0.0) { + if (d <= (((double) (long) LONG_MIN) - 0.5)) { + tooLarge: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent", -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + temp = (long) (d - 0.5); + } else { + if (d >= (((double) LONG_MAX + 0.5))) { + goto tooLarge; + } + temp = (long) (d + 0.5); + } + if (IS_NAN(temp) || IS_INF(temp)) { + TclExprFloatError(interp, temp); + result = TCL_ERROR; + goto done; + } + iResult = (long) temp; + } + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprSrandFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + long i = 0; /* Initialized to avoid compiler warning. */ + int result; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. Use the value + * to reset the random number seed. + */ + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", + ((tPtr == &tclDoubleType)? "floating-point value" : "non-numeric string"), + " as argument to srand", (char *) NULL); + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; + } + } + + /* + * Reset the seed. + */ + + iPtr->flags |= RAND_SEED_INITIALIZED; + iPtr->randSeed = i; + + /* + * To avoid duplicating the random number generation code we simply + * clean up our state and call the real random number function. That + * function will always succeed. + */ + + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + + ExprRandFunc(interp, eePtr, clientData); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ExprCallMathFunc -- + * + * This procedure is invoked to call a non-builtin math function + * during the execution of an expression. + * + * 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 the interpreter's + * result. After a successful return this procedure pushes a Tcl object + * holding the result. + * + * Side effects: + * None, unless the called math function has side effects. + * + *---------------------------------------------------------------------- + */ + +static int +ExprCallMathFunc(interp, eePtr, objc, objv) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + int objc; /* Number of arguments. The function name is + * the 0-th argument. */ + Tcl_Obj **objv; /* The array of arguments. The function name + * is objv[0]. */ +{ + Interp *iPtr = (Interp *) interp; + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + char *funcName; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; /* Information about math function. */ + Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ + Tcl_Value funcResult; /* Result of function call as Tcl_Value. */ + register Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + long i; + double d; + int j, k, result; + + Tcl_ResetResult(interp); + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Look up the MathFunc record for the function. + * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS NULLS. + */ + + funcName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown math function \"", funcName, "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + if (mathFuncPtr->numArgs != (objc-1)) { + panic("ExprCallMathFunc: expected number of args %d != actual number %d", + mathFuncPtr->numArgs, objc); + result = TCL_ERROR; + goto done; + } + + /* + * Collect the arguments for the function, if there are any, into the + * array "args". Note that args[0] will have the Tcl_Value that + * corresponds to objv[1]. + */ + + for (j = 1, k = 0; j < objc; j++, k++) { + valuePtr = objv[j]; + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + } else { + /* + * Try to convert to int first then double. + * FAILS IF STRING REP HAS NULLS. + */ + + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d); + } + if (result != TCL_OK) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + tPtr = valuePtr->typePtr; + } + + /* + * Copy the object's numeric value to the argument record, + * converting it if necessary. + */ + + if (tPtr == &tclIntType) { + if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { + args[k].type = TCL_DOUBLE; + args[k].doubleValue = i; + } else { + args[k].type = TCL_INT; + args[k].intValue = i; + } + } else { + if (mathFuncPtr->argTypes[k] == TCL_INT) { + args[k].type = TCL_INT; + args[k].intValue = (long) d; + } else { + args[k].type = TCL_DOUBLE; + args[k].doubleValue = d; + } + } + } + + /* + * 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) { + goto done; + } + + /* + * Pop the objc top stack elements and decrement their ref counts. + */ + + i = (stackTop - (objc-1)); + while (i <= stackTop) { + valuePtr = stackPtr[i].o; + Tcl_DecrRefCount(valuePtr); + i++; + } + stackTop -= objc; + + /* + * Push the call's object result. + */ + + if (funcResult.type == TCL_INT) { + PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue)); + } else { + d = funcResult.doubleValue; + if (IS_NAN(d) || IS_INF(d)) { + TclExprFloatError(interp, d); + result = TCL_ERROR; + goto done; + } + PUSH_OBJECT(Tcl_NewDoubleObj(d)); + } + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + DECACHE_STACK_INFO(); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclExprFloatError -- + * + * This procedure is called when an error occurs during a + * floating-point operation. It reads errno and sets + * interp->objResultPtr accordingly. + * + * Results: + * interp->objResultPtr 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 *s; + + Tcl_ResetResult(interp); + if ((errno == EDOM) || (value != value)) { + s = "domain error: argument not in valid range"; + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL); + } else if ((errno == ERANGE) || IS_INF(value)) { + if (value == 0.0) { + s = "floating-point value too small to represent"; + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL); + } else { + s = "floating-point value too large to represent"; + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); + } + } else { /* FAILS IF STRING REP CONTAINS NULLS */ + char msg[100]; + + sprintf(msg, "unknown floating-point error, errno = %d", errno); + Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1); + Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL); + } +} + +#ifdef TCL_COMPILE_STATS +/* + *---------------------------------------------------------------------- + * + * TclLog2 -- + * + * Procedure used while collecting compilation statistics to determine + * the log base 2 of an integer. + * + * Results: + * Returns the log base 2 of the operand. If the argument is less + * than or equal to zero, a zero is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclLog2(value) + register int value; /* The integer for which to compute the + * log base 2. */ +{ + register int n = value; + register int result = 0; + + while (n > 1) { + n = n >> 1; + result++; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * EvalStatsCmd -- + * + * Implements the "evalstats" command that prints instruction execution + * counts to stdout. + * + * Results: + * Standard Tcl results. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +EvalStatsCmd(unused, interp, argc, argv) + ClientData unused; /* Unused. */ + Tcl_Interp *interp; /* The current interpreter. */ + int argc; /* The number of arguments. */ + char **argv; /* The argument strings. */ +{ + register double total = 0.0; + register int i; + int maxSizeDecade = 0; + double totalHeaderBytes = (tclNumCompilations * sizeof(ByteCode)); + + for (i = 0; i < 256; i++) { + if (instructionCount[i] != 0) { + total += instructionCount[i]; + } + } + + for (i = 31; i >= 0; i--) { + if ((tclSourceCount[i] > 0) && (tclByteCodeCount[i] > 0)) { + maxSizeDecade = i; + break; + } + } + + fprintf(stdout, "\nNumber of compilations %ld\n", + tclNumCompilations); + fprintf(stdout, "Number of executions %ld\n", + numExecutions); + fprintf(stdout, "Average executions/compilation %.0f\n", + ((float) numExecutions/tclNumCompilations)); + + fprintf(stdout, "\nInstructions executed %.0f\n", + total); + fprintf(stdout, "Average instructions/compile %.0f\n", + total/tclNumCompilations); + fprintf(stdout, "Average instructions/execution %.0f\n", + total/numExecutions); + + fprintf(stdout, "\nTotal source bytes %.6g\n", + tclTotalSourceBytes); + fprintf(stdout, "Total code bytes %.6g\n", + tclTotalCodeBytes); + fprintf(stdout, "Average code/compilation %.0f\n", + tclTotalCodeBytes/tclNumCompilations); + fprintf(stdout, "Average code/source %.2f\n", + tclTotalCodeBytes/tclTotalSourceBytes); + fprintf(stdout, "Current source bytes %.6g\n", + tclCurrentSourceBytes); + fprintf(stdout, "Current code bytes %.6g\n", + tclCurrentCodeBytes); + fprintf(stdout, "Current code/source %.2f\n", + tclCurrentCodeBytes/tclCurrentSourceBytes); + + fprintf(stdout, "\nTotal objects allocated %ld\n", + tclObjsAlloced); + fprintf(stdout, "Total objects freed %ld\n", + tclObjsFreed); + fprintf(stdout, "Current objects: %ld\n", + (tclObjsAlloced - tclObjsFreed)); + + fprintf(stdout, "\nBreakdown of code byte requirements:\n"); + fprintf(stdout, " Total bytes Pct of Avg per\n"); + fprintf(stdout, " all code compile\n"); + fprintf(stdout, "Total code %12.6g 100%% %8.2f\n", + tclTotalCodeBytes, tclTotalCodeBytes/tclNumCompilations); + fprintf(stdout, "Header %12.6g %8.2f%% %8.2f\n", + totalHeaderBytes, + ((totalHeaderBytes * 100.0) / tclTotalCodeBytes), + totalHeaderBytes/tclNumCompilations); + fprintf(stdout, "Instructions %12.6g %8.2f%% %8.2f\n", + tclTotalInstBytes, + ((tclTotalInstBytes * 100.0) / tclTotalCodeBytes), + tclTotalInstBytes/tclNumCompilations); + fprintf(stdout, "Objects %12.6g %8.2f%% %8.2f\n", + tclTotalObjBytes, + ((tclTotalObjBytes * 100.0) / tclTotalCodeBytes), + tclTotalObjBytes/tclNumCompilations); + fprintf(stdout, "Exception table %12.6g %8.2f%% %8.2f\n", + tclTotalExceptBytes, + ((tclTotalExceptBytes * 100.0) / tclTotalCodeBytes), + tclTotalExceptBytes/tclNumCompilations); + fprintf(stdout, "Auxiliary data %12.6g %8.2f%% %8.2f\n", + tclTotalAuxBytes, + ((tclTotalAuxBytes * 100.0) / tclTotalCodeBytes), + tclTotalAuxBytes/tclNumCompilations); + fprintf(stdout, "Command map %12.6g %8.2f%% %8.2f\n", + tclTotalCmdMapBytes, + ((tclTotalCmdMapBytes * 100.0) / tclTotalCodeBytes), + tclTotalCmdMapBytes/tclNumCompilations); + + fprintf(stdout, "\nSource and ByteCode size distributions:\n"); + fprintf(stdout, " binary decade source code\n"); + for (i = 0; i <= maxSizeDecade; i++) { + int decadeLow, decadeHigh; + + if (i == 0) { + decadeLow = 0; + } else { + decadeLow = 1 << i; + } + decadeHigh = (1 << (i+1)) - 1; + fprintf(stdout, " %6d -%6d %6d %6d\n", + decadeLow, decadeHigh, + tclSourceCount[i], tclByteCodeCount[i]); + } + + fprintf(stdout, "\nInstruction counts:\n"); + for (i = 0; i < 256; i++) { + if (instructionCount[i]) { + fprintf(stdout, "%20s %8d %6.2f%%\n", + opName[i], instructionCount[i], + (instructionCount[i] * 100.0)/total); + } + } + +#ifdef TCL_MEM_DEBUG + fprintf(stdout, "\nHeap Statistics:\n"); + TclDumpMemoryInfo(stdout); +#endif /* TCL_MEM_DEBUG */ + + return TCL_OK; +} +#endif /* TCL_COMPILE_STATS */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandFromObj -- + * + * Returns the command specified by the name in a Tcl_Obj. + * + * Results: + * Returns a token for the command if it is found. Otherwise, if it + * can't be found or there is an error, returns NULL. + * + * Side effects: + * May update the internal representation for the object, caching + * the command reference so that the next time this procedure is + * called with the same object, the command can be found quickly. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_GetCommandFromObj(interp, objPtr) + Tcl_Interp *interp; /* The interpreter in which to resolve the + * command and to report errors. */ + register Tcl_Obj *objPtr; /* The object containing the command's + * name. If the name starts with "::", will + * be looked up in global namespace. Else, + * looked up first in the current namespace + * if contextNsPtr is NULL, then in global + * namespace. */ +{ + Interp *iPtr = (Interp *) interp; + register ResolvedCmdName *resPtr; + register Command *cmdPtr; + Namespace *currNsPtr; + int result; + + /* + * Get the internal representation, converting to a command type if + * needed. The internal representation is a ResolvedCmdName that points + * to the actual command. + */ + + if (objPtr->typePtr != &tclCmdNameType) { + result = tclCmdNameType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + return (Tcl_Command) NULL; + } + } + resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + /* + * Check the context namespace and the namespace epoch of the resolved + * symbol to make sure that it is fresh. If not, then force another + * conversion to the command type, to discard the old rep and create a + * new one. Note that we verify that the namespace id of the context + * namespace is the same as the one we cached; this insures that the + * namespace wasn't deleted and a new one created at the same address + * with the same command epoch. + */ + + cmdPtr = NULL; + if ((resPtr != NULL) + && (resPtr->refNsPtr == currNsPtr) + && (resPtr->refNsId == currNsPtr->nsId) + && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { + cmdPtr = resPtr->cmdPtr; + if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) { + cmdPtr = NULL; + } + } + + if (cmdPtr == NULL) { + result = tclCmdNameType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + return (Tcl_Command) NULL; + } + resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + if (resPtr != NULL) { + cmdPtr = resPtr->cmdPtr; + } + } + + if (cmdPtr == NULL) { + return (Tcl_Command) NULL; + } + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeCmdNameInternalRep -- + * + * Frees the resources associated with a cmdName object's internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Decrements the ref count of any cached ResolvedCmdName structure + * pointed to by the cmdName's internal representation. If this is + * the last use of the ResolvedCmdName, it is freed. This in turn + * decrements the ref count of the Command structure pointed to by + * the ResolvedSymbol, which may free the Command structure. + * + *---------------------------------------------------------------------- + */ + +static void +FreeCmdNameInternalRep(objPtr) + register Tcl_Obj *objPtr; /* CmdName object with internal + * representation to free. */ +{ + register ResolvedCmdName *resPtr = + (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + + if (resPtr != NULL) { + /* + * Decrement the reference count of the ResolvedCmdName structure. + * If there are no more uses, free the ResolvedCmdName structure. + */ + + resPtr->refCount--; + if (resPtr->refCount == 0) { + /* + * Now free the cached command, unless it is still in its + * hash table or if there are other references to it + * from other cmdName objects. + */ + + Command *cmdPtr = resPtr->cmdPtr; + TclCleanupCommand(cmdPtr); + ckfree((char *) resPtr); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * DupCmdNameInternalRep -- + * + * Initialize the internal representation of an cmdName Tcl_Obj to a + * copy of the internal representation of an existing cmdName object. + * + * Results: + * None. + * + * Side effects: + * "copyPtr"s internal rep is set to point to the ResolvedCmdName + * structure corresponding to "srcPtr"s internal rep. Increments the + * ref count of the ResolvedCmdName structure pointed to by the + * cmdName's internal representation. + * + *---------------------------------------------------------------------- + */ + +static void +DupCmdNameInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + register ResolvedCmdName *resPtr = + (ResolvedCmdName *) srcPtr->internalRep.otherValuePtr; + + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + if (resPtr != NULL) { + resPtr->refCount++; + } + copyPtr->typePtr = &tclCmdNameType; +} + +/* + *---------------------------------------------------------------------- + * + * SetCmdNameFromAny -- + * + * Generate an cmdName internal form for the Tcl object "objPtr". + * + * Results: + * The return value is a standard Tcl result. The conversion always + * succeeds and TCL_OK is returned. + * + * Side effects: + * A pointer to a ResolvedCmdName structure that holds a cached pointer + * to the command with a name that matches objPtr's string rep is + * stored as objPtr's internal representation. This ResolvedCmdName + * pointer will be NULL if no matching command was found. The ref count + * of the cached Command's structure (if any) is also incremented. + * + *---------------------------------------------------------------------- + */ + +static int +SetCmdNameFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Interp *iPtr = (Interp *) interp; + char *name; + Tcl_Command cmd; + register Command *cmdPtr; + Namespace *currNsPtr; + register ResolvedCmdName *resPtr; + + /* + * Get "objPtr"s string representation. Make it up-to-date if necessary. + */ + + name = objPtr->bytes; + if (name == NULL) { + name = Tcl_GetStringFromObj(objPtr, (int *) NULL); + } + + /* + * Find the Command structure, if any, that describes the command called + * "name". Build a ResolvedCmdName that holds a cached pointer to this + * Command, and bump the reference count in the referenced Command + * structure. A Command structure will not be deleted as long as it is + * referenced from a CmdName object. + */ + + cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL, + /*flags*/ 0); + cmdPtr = (Command *) cmd; + if (cmdPtr != NULL) { + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + } else { + resPtr = NULL; /* no command named "name" was found */ + } + + /* + * Free the old internalRep before setting the new one. We do this as + * late as possible to allow the conversion code, in particular + * GetStringFromObj, to use that old internalRep. If no Command + * structure was found, leave NULL as the cached value. + */ + + if ((objPtr->typePtr != NULL) + && (objPtr->typePtr->freeIntRepProc != NULL)) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfCmdName -- + * + * Update the string representation for an cmdName object. + * + * Results: + * None. + * + * Side effects: + * Generates a panic. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfCmdName(objPtr) + Tcl_Obj *objPtr; /* CmdName obj to update string rep. */ +{ + /* + * This procedure is never invoked since the internal representation of + * a cmdName object is never modified. + */ + + panic("UpdateStringOfCmdName should never be invoked"); +} + +#ifdef TCL_COMPILE_DEBUG +/* + *---------------------------------------------------------------------- + * + * StringForResultCode -- + * + * Procedure that returns a human-readable string representing a + * Tcl result code such as TCL_ERROR. + * + * Results: + * If the result code is one of the standard Tcl return codes, the + * result is a string representing that code such as "TCL_ERROR". + * Otherwise, the result string is that code formatted as a + * sequence of decimal digit characters. Note that the resulting + * string must not be modified by the caller. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +StringForResultCode(result) + int result; /* The Tcl result code for which to + * generate a string. */ +{ + static char buf[20]; + + if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { + return resultStrings[result]; + } + TclFormatInt(buf, result); + return buf; +} +#endif /* TCL_COMPILE_DEBUG */ diff --git a/tcl/generic/tclFCmd.c b/tcl/generic/tclFCmd.c new file mode 100644 index 00000000000..1260cda4f05 --- /dev/null +++ b/tcl/generic/tclFCmd.c @@ -0,0 +1,816 @@ +/* + * tclFCmd.c + * + * This file implements the generic portion of file manipulation + * subcommands of the "file" command. + * + * 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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Declarations for local procedures defined in this file: + */ + +static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp, + char *source, char *dest, int copyFlag, + int force)); +static char * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, + char *path, Tcl_DString *bufferPtr)); +static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int copyFlag)); +static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int *forcePtr)); + +/* + *--------------------------------------------------------------------------- + * + * TclFileRenameCmd + * + * This procedure implements the "rename" subcommand of the "file" + * command. Filename arguments need to be translated to native + * format before being passed to platform-specific code that + * implements rename functionality. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *--------------------------------------------------------------------------- + */ + +int +TclFileRenameCmd(interp, argc, argv) + Tcl_Interp *interp; /* Interp for error reporting. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings passed to Tcl_FileCmd. */ +{ + return FileCopyRename(interp, argc, argv, 0); +} + +/* + *--------------------------------------------------------------------------- + * + * TclFileCopyCmd + * + * This procedure implements the "copy" subcommand of the "file" + * command. Filename arguments need to be translated to native + * format before being passed to platform-specific code that + * implements copy functionality. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *--------------------------------------------------------------------------- + */ + +int +TclFileCopyCmd(interp, argc, argv) + Tcl_Interp *interp; /* Used for error reporting */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings passed to Tcl_FileCmd. */ +{ + return FileCopyRename(interp, argc, argv, 1); +} + +/* + *--------------------------------------------------------------------------- + * + * FileCopyRename -- + * + * Performs the work of TclFileRenameCmd and TclFileCopyCmd. + * See comments for those procedures. + * + * Results: + * See above. + * + * Side effects: + * See above. + * + *--------------------------------------------------------------------------- + */ + +static int +FileCopyRename(interp, argc, argv, copyFlag) + Tcl_Interp *interp; /* Used for error reporting. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings passed to Tcl_FileCmd. */ + int copyFlag; /* If non-zero, copy source(s). Otherwise, + * rename them. */ +{ + int i, result, force; + struct stat statBuf; + Tcl_DString targetBuffer; + char *target; + + i = FileForceOption(interp, argc - 2, argv + 2, &force); + if (i < 0) { + return TCL_ERROR; + } + i += 2; + if ((argc - i) < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " ?options? source ?source ...? target\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * If target doesn't exist or isn't a directory, try the copy/rename. + * More than 2 arguments is only valid if the target is an existing + * directory. + */ + + target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer); + if (target == NULL) { + return TCL_ERROR; + } + + result = TCL_OK; + + /* + * Call TclStat() so that if target is a symlink that points to a + * directory we will put the sources in that directory instead of + * overwriting the symlink. + */ + + if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { + if ((argc - i) > 2) { + errno = ENOTDIR; + Tcl_PosixError(interp); + Tcl_AppendResult(interp, "error ", + ((copyFlag) ? "copying" : "renaming"), ": target \"", + argv[argc - 1], "\" is not a directory", (char *) NULL); + result = TCL_ERROR; + } else { + /* + * Even though already have target == translated(argv[i+1]), + * pass the original argument down, so if there's an error, the + * error message will reflect the original arguments. + */ + + result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag, + force); + } + Tcl_DStringFree(&targetBuffer); + return result; + } + + /* + * Move each source file into target directory. Extract the basename + * from each source, and append it to the end of the target path. + */ + + for ( ; i < argc - 1; i++) { + char *jargv[2]; + char *source, *newFileName; + Tcl_DString sourceBuffer, newFileNameBuffer; + + source = FileBasename(interp, argv[i], &sourceBuffer); + if (source == NULL) { + result = TCL_ERROR; + break; + } + jargv[0] = argv[argc - 1]; + jargv[1] = source; + Tcl_DStringInit(&newFileNameBuffer); + newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer); + result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag, + force); + Tcl_DStringFree(&sourceBuffer); + Tcl_DStringFree(&newFileNameBuffer); + + if (result == TCL_ERROR) { + break; + } + } + Tcl_DStringFree(&targetBuffer); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TclFileMakeDirsCmd + * + * This procedure implements the "mkdir" subcommand of the "file" + * command. Filename arguments need to be translated to native + * format before being passed to platform-specific code that + * implements mkdir functionality. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ +int +TclFileMakeDirsCmd(interp, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + int argc; /* Number of arguments */ + char **argv; /* Argument strings passed to Tcl_FileCmd. */ +{ + Tcl_DString nameBuffer, targetBuffer; + char *errfile; + int result, i, j, pargc; + char **pargv; + struct stat statBuf; + + pargv = NULL; + errfile = NULL; + Tcl_DStringInit(&nameBuffer); + Tcl_DStringInit(&targetBuffer); + + result = TCL_OK; + for (i = 2; i < argc; i++) { + char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer); + if (name == NULL) { + result = TCL_ERROR; + break; + } + + Tcl_SplitPath(name, &pargc, &pargv); + if (pargc == 0) { + errno = ENOENT; + errfile = argv[i]; + break; + } + for (j = 0; j < pargc; j++) { + char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer); + + /* + * Call TclStat() so that if target is a symlink that points + * to a directory we will create subdirectories in that + * directory. + */ + + if (TclStat(target, &statBuf) == 0) { + if (!S_ISDIR(statBuf.st_mode)) { + errno = EEXIST; + errfile = target; + goto done; + } + } else if ((errno != ENOENT) + || (TclpCreateDirectory(target) != TCL_OK)) { + errfile = target; + goto done; + } + Tcl_DStringFree(&targetBuffer); + } + ckfree((char *) pargv); + pargv = NULL; + Tcl_DStringFree(&nameBuffer); + } + + done: + if (errfile != NULL) { + Tcl_AppendResult(interp, "can't create directory \"", + errfile, "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + } + + Tcl_DStringFree(&nameBuffer); + Tcl_DStringFree(&targetBuffer); + if (pargv != NULL) { + ckfree((char *) pargv); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclFileDeleteCmd + * + * This procedure implements the "delete" subcommand of the "file" + * command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclFileDeleteCmd(interp, argc, argv) + Tcl_Interp *interp; /* Used for error reporting */ + int argc; /* Number of arguments */ + char **argv; /* Argument strings passed to Tcl_FileCmd. */ +{ + Tcl_DString nameBuffer, errorBuffer; + int i, force, result; + char *errfile; + + i = FileForceOption(interp, argc - 2, argv + 2, &force); + if (i < 0) { + return TCL_ERROR; + } + i += 2; + if ((argc - i) < 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " ?options? file ?file ...?\"", (char *) NULL); + return TCL_ERROR; + } + + errfile = NULL; + result = TCL_OK; + Tcl_DStringInit(&errorBuffer); + Tcl_DStringInit(&nameBuffer); + + for ( ; i < argc; i++) { + struct stat statBuf; + char *name; + + errfile = argv[i]; + Tcl_DStringSetLength(&nameBuffer, 0); + name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer); + if (name == NULL) { + result = TCL_ERROR; + goto done; + } + + /* + * Call lstat() to get info so can delete symbolic link itself. + */ + + if (lstat(name, &statBuf) != 0) { + /* + * Trying to delete a file that does not exist is not + * considered an error, just a no-op + */ + + if (errno != ENOENT) { + result = TCL_ERROR; + } + } else if (S_ISDIR(statBuf.st_mode)) { + result = TclpRemoveDirectory(name, force, &errorBuffer); + if (result != TCL_OK) { + if ((force == 0) && (errno == EEXIST)) { + Tcl_AppendResult(interp, "error deleting \"", argv[i], + "\": directory not empty", (char *) NULL); + Tcl_PosixError(interp); + goto done; + } + + /* + * If possible, use the untranslated name for the file. + */ + + errfile = Tcl_DStringValue(&errorBuffer); + if (strcmp(name, errfile) == 0) { + errfile = argv[i]; + } + } + } else { + result = TclpDeleteFile(name); + } + + if (result == TCL_ERROR) { + break; + } + } + if (result != TCL_OK) { + Tcl_AppendResult(interp, "error deleting \"", errfile, + "\": ", Tcl_PosixError(interp), (char *) NULL); + } + done: + Tcl_DStringFree(&errorBuffer); + Tcl_DStringFree(&nameBuffer); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * CopyRenameOneFile + * + * Copies or renames specified source file or directory hierarchy + * to the specified target. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Target is overwritten if the force flag is set. Attempting to + * copy/rename a file onto a directory or a directory onto a file + * will always result in an error. + * + *---------------------------------------------------------------------- + */ + +static int +CopyRenameOneFile(interp, source, target, copyFlag, force) + Tcl_Interp *interp; /* Used for error reporting. */ + char *source; /* Pathname of file to copy. May need to + * be translated. */ + char *target; /* Pathname of file to create/overwrite. + * May need to be translated. */ + int copyFlag; /* If non-zero, copy files. Otherwise, + * rename them. */ + int force; /* If non-zero, overwrite target file if it + * exists. Otherwise, error if target already + * exists. */ +{ + int result; + Tcl_DString sourcePath, targetPath, errorBuffer; + char *targetName, *sourceName, *errfile; + struct stat sourceStatBuf, targetStatBuf; + + sourceName = Tcl_TranslateFileName(interp, source, &sourcePath); + if (sourceName == NULL) { + return TCL_ERROR; + } + targetName = Tcl_TranslateFileName(interp, target, &targetPath); + if (targetName == NULL) { + Tcl_DStringFree(&sourcePath); + return TCL_ERROR; + } + + errfile = NULL; + result = TCL_ERROR; + Tcl_DStringInit(&errorBuffer); + + /* + * We want to copy/rename links and not the files they point to, so we + * use lstat(). If target is a link, we also want to replace the + * link and not the file it points to, so we also use lstat() on the + * target. + */ + + if (lstat(sourceName, &sourceStatBuf) != 0) { + errfile = source; + goto done; + } + if (lstat(targetName, &targetStatBuf) != 0) { + if (errno != ENOENT) { + errfile = target; + goto done; + } + } else { + if (force == 0) { + errno = EEXIST; + errfile = target; + goto done; + } + + /* + * Prevent copying or renaming a file onto itself. Under Windows, + * stat always returns 0 for st_ino. However, the Windows-specific + * code knows how to deal with copying or renaming a file on top of + * itself. It might be a good idea to write a stat that worked. + */ + + if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { + if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && + (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { + result = TCL_OK; + goto done; + } + } + + /* + * Prevent copying/renaming a file onto a directory and + * vice-versa. This is a policy decision based on the fact that + * existing implementations of copy and rename on all platforms + * also prevent this. + */ + + if (S_ISDIR(sourceStatBuf.st_mode) + && !S_ISDIR(targetStatBuf.st_mode)) { + errno = EISDIR; + Tcl_AppendResult(interp, "can't overwrite file \"", target, + "\" with directory \"", source, "\"", (char *) NULL); + goto done; + } + if (!S_ISDIR(sourceStatBuf.st_mode) + && S_ISDIR(targetStatBuf.st_mode)) { + errno = EISDIR; + Tcl_AppendResult(interp, "can't overwrite directory \"", target, + "\" with file \"", source, "\"", (char *) NULL); + goto done; + } + } + + if (copyFlag == 0) { + result = TclpRenameFile(sourceName, targetName); + if (result == TCL_OK) { + goto done; + } + + if (errno == EINVAL) { + Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"", + target, "\": trying to rename a volume or ", + "move a directory into itself", (char *) NULL); + goto done; + } else if (errno != EXDEV) { + errfile = target; + goto done; + } + + /* + * The rename failed because the move was across file systems. + * Fall through to copy file and then remove original. Note that + * the low-level TclpRenameFile is allowed to implement + * cross-filesystem moves itself. + */ + } + + if (S_ISDIR(sourceStatBuf.st_mode)) { + result = TclpCopyDirectory(sourceName, targetName, &errorBuffer); + if (result != TCL_OK) { + errfile = Tcl_DStringValue(&errorBuffer); + if (strcmp(errfile, sourceName) == 0) { + errfile = source; + } else if (strcmp(errfile, targetName) == 0) { + errfile = target; + } + } + } else { + result = TclpCopyFile(sourceName, targetName); + if (result != TCL_OK) { + /* + * Well, there really shouldn't be a problem with source, + * because up there we checked to see if it was ok to copy it. + */ + + errfile = target; + } + } + if ((copyFlag == 0) && (result == TCL_OK)) { + if (S_ISDIR(sourceStatBuf.st_mode)) { + result = TclpRemoveDirectory(sourceName, 1, &errorBuffer); + if (result != TCL_OK) { + errfile = Tcl_DStringValue(&errorBuffer); + if (strcmp(errfile, sourceName) == 0) { + errfile = source; + } + } + } else { + result = TclpDeleteFile(sourceName); + if (result != TCL_OK) { + errfile = source; + } + } + if (result != TCL_OK) { + Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ", + Tcl_PosixError(interp), (char *) NULL); + errfile = NULL; + } + } + + done: + if (errfile != NULL) { + Tcl_AppendResult(interp, + ((copyFlag) ? "error copying \"" : "error renaming \""), + source, (char *) NULL); + if (errfile != source) { + Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL); + if (errfile != target) { + Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL); + } + } + Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), + (char *) NULL); + } + Tcl_DStringFree(&errorBuffer); + Tcl_DStringFree(&sourcePath); + Tcl_DStringFree(&targetPath); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * FileForceOption -- + * + * Helps parse command line options for file commands that take + * the "-force" and "--" options. + * + * Results: + * The return value is how many arguments from argv were consumed + * by this function, or -1 if there was an error parsing the + * options. If an error occurred, an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +FileForceOption(interp, argc, argv, forcePtr) + Tcl_Interp *interp; /* Interp, for error return. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. First command line + option, if it exists, begins at */ + int *forcePtr; /* If the "-force" was specified, *forcePtr + * is filled with 1, otherwise with 0. */ +{ + int force, i; + + force = 0; + for (i = 0; i < argc; i++) { + if (argv[i][0] != '-') { + break; + } + if (strcmp(argv[i], "-force") == 0) { + force = 1; + } else if (strcmp(argv[i], "--") == 0) { + i++; + break; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[i], + "\": should be -force or --", (char *)NULL); + return -1; + } + } + *forcePtr = force; + return i; +} +/* + *--------------------------------------------------------------------------- + * + * FileBasename -- + * + * Given a path in either tcl format (with / separators), or in the + * platform-specific format for the current platform, return all the + * characters in the path after the last directory separator. But, + * if path is the root directory, returns no characters. + * + * Results: + * Appends the string that represents the basename to the end of + * the specified initialized DString, returning a pointer to the + * resulting string. If there is an error, an error message is left + * in interp, NULL is returned, and the Tcl_DString is unmodified. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static char * +FileBasename(interp, path, bufferPtr) + Tcl_Interp *interp; /* Interp, for error return. */ + char *path; /* Path whose basename to extract. */ + Tcl_DString *bufferPtr; /* Initialized DString that receives + * basename. */ +{ + int argc; + char **argv; + + Tcl_SplitPath(path, &argc, &argv); + if (argc == 0) { + Tcl_DStringInit(bufferPtr); + } else { + if ((argc == 1) && (*path == '~')) { + Tcl_DString buffer; + + ckfree((char *) argv); + path = Tcl_TranslateFileName(interp, path, &buffer); + if (path == NULL) { + return NULL; + } + Tcl_SplitPath(path, &argc, &argv); + Tcl_DStringFree(&buffer); + } + Tcl_DStringInit(bufferPtr); + + /* + * Return the last component, unless it is the only component, and it + * is the root of an absolute path. + */ + + if (argc > 0) { + if ((argc > 1) + || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { + Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1); + } + } + } + ckfree((char *) argv); + return Tcl_DStringValue(bufferPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclFileAttrsCmd -- + * + * Sets or gets the platform-specific attributes of a file. The objc-objv + * points to the file name with the rest of the command line following. + * This routine uses platform-specific tables of option strings + * and callbacks. The callback to get the attributes take three + * parameters: + * Tcl_Interp *interp; The interp to report errors with. + * Since this is an object-based API, + * the object form of the result should be + * used. + * CONST char *fileName; This is extracted using + * Tcl_TranslateFileName. + * TclObj **attrObjPtrPtr; A new object to hold the attribute + * is allocated and put here. + * The first two parameters of the callback used to write out the + * attributes are the same. The third parameter is: + * CONST *attrObjPtr; A pointer to the object that has + * the new attribute. + * They both return standard TCL errors; if the routine to get + * an attribute fails, no object is allocated and *attrObjPtrPtr + * is unchanged. + * + * Results: + * Standard TCL error. + * + * Side effects: + * May set file attributes for the file name. + * + *---------------------------------------------------------------------- + */ + +int +TclFileAttrsCmd(interp, objc, objv) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int objc; /* Number of command line arguments. */ + Tcl_Obj *CONST objv[]; /* The command line objects. */ +{ + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + char *fileName; + int length, index; + Tcl_Obj *listObjPtr; + Tcl_Obj *elementObjPtr; + Tcl_DString buffer; + + if ((objc > 2) && ((objc % 2) == 0)) { + Tcl_AppendStringsToObj(resultPtr, + "wrong # args: must be \"file attributes name ?option? ?value? ?option value? ...\"", + (char *) NULL); + return TCL_ERROR; + } + + fileName = Tcl_GetStringFromObj(objv[0], &length); + if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) { + return TCL_ERROR; + } + fileName = Tcl_DStringValue(&buffer); + + if (objc == 1) { + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + for (index = 0; tclpFileAttrStrings[index] != NULL; index++) { + elementObjPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1); + Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr); + if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, + &elementObjPtr) != TCL_OK) { + Tcl_DecrRefCount(listObjPtr); + return TCL_ERROR; + } + Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr); + } + Tcl_SetObjResult(interp, listObjPtr); + } else if (objc == 2) { + if (Tcl_GetIndexFromObj(interp, objv[1], tclpFileAttrStrings, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, + &elementObjPtr) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, elementObjPtr); + } else { + int i; + + for (i = 1; i < objc ; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName, + objv[i + 1]) != TCL_OK) { + return TCL_ERROR; + } + } + } + + Tcl_DStringFree(&buffer); + + return TCL_OK; +} diff --git a/tcl/generic/tclFileName.c b/tcl/generic/tclFileName.c new file mode 100644 index 00000000000..d57aaedefdb --- /dev/null +++ b/tcl/generic/tclFileName.c @@ -0,0 +1,1619 @@ +/* + * tclFileName.c -- + * + * This file contains routines for converting file names betwen + * native and network form. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" +#include "tclRegexp.h" + +/* + * This variable indicates whether the cleanup procedure has been + * registered for this file yet. + */ + +static int initialized = 0; + +/* + * The following regular expression matches the root portion of a Windows + * absolute or volume relative path. It will match both UNC and drive relative + * paths. + */ + +#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\][/\\]+([^/\\]+)[/\\]+([^/\\]+)|([/\\]))([/\\])*" + +/* + * The following regular expression matches the root portion of a Macintosh + * absolute path. It will match degenerate Unix-style paths, tilde paths, + * Unix-style paths, and Mac paths. + */ + +#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$" + +/* + * The following variables are used to hold precompiled regular expressions + * for use in filename matching. + */ + +static regexp *winRootPatternPtr = NULL; +static regexp *macRootPatternPtr = NULL; + +/* + * The following variable is set in the TclPlatformInit call to one + * of: TCL_PLATFORM_UNIX, TCL_PLATFORM_MAC, or TCL_PLATFORM_WINDOWS. + */ + +TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; + +/* + * Prototypes for local procedures defined in this file: + */ + +static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, + char *user, Tcl_DString *resultPtr)); +static char * ExtractWinRoot _ANSI_ARGS_((char *path, + Tcl_DString *resultPtr, int offset)); +static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); +static int SkipToChar _ANSI_ARGS_((char **stringPtr, + char *match)); +static char * SplitMacPath _ANSI_ARGS_((char *path, + Tcl_DString *bufPtr)); +static char * SplitWinPath _ANSI_ARGS_((char *path, + Tcl_DString *bufPtr)); +static char * SplitUnixPath _ANSI_ARGS_((char *path, + Tcl_DString *bufPtr)); + +/* + *---------------------------------------------------------------------- + * + * FileNameCleanup -- + * + * This procedure is a Tcl_ExitProc used to clean up the static + * data structures used in this file. + * + * Results: + * None. + * + * Side effects: + * Deallocates storage used by the procedures in this file. + * + *---------------------------------------------------------------------- + */ + +static void +FileNameCleanup(clientData) + ClientData clientData; /* Not used. */ +{ + if (winRootPatternPtr != NULL) { + ckfree((char *)winRootPatternPtr); + winRootPatternPtr = (regexp *) NULL; + } + if (macRootPatternPtr != NULL) { + ckfree((char *)macRootPatternPtr); + macRootPatternPtr = (regexp *) NULL; + } + initialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * ExtractWinRoot -- + * + * Matches the root portion of a Windows path and appends it + * to the specified Tcl_DString. + * + * Results: + * Returns the position in the path immediately after the root + * including any trailing slashes. + * Appends a cleaned up version of the root to the Tcl_DString + * at the specified offest. + * + * Side effects: + * Modifies the specified Tcl_DString. + * + *---------------------------------------------------------------------- + */ + +static char * +ExtractWinRoot(path, resultPtr, offset) + char *path; /* Path to parse. */ + Tcl_DString *resultPtr; /* Buffer to hold result. */ + int offset; /* Offset in buffer where result should be + * stored. */ +{ + int length; + + /* + * Initialize the path name parser for Windows path names. + */ + + if (winRootPatternPtr == NULL) { + winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + + /* + * Match the root portion of a Windows path name. + */ + + if (!TclRegExec(winRootPatternPtr, path, path)) { + return path; + } + + Tcl_DStringSetLength(resultPtr, offset); + + if (winRootPatternPtr->startp[2] != NULL) { + Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[2], 2); + if (winRootPatternPtr->startp[6] != NULL) { + Tcl_DStringAppend(resultPtr, "/", 1); + } + } else if (winRootPatternPtr->startp[4] != NULL) { + Tcl_DStringAppend(resultPtr, "//", 2); + length = winRootPatternPtr->endp[3] + - winRootPatternPtr->startp[3]; + Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[3], length); + Tcl_DStringAppend(resultPtr, "/", 1); + length = winRootPatternPtr->endp[4] + - winRootPatternPtr->startp[4]; + Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[4], length); + } else { + Tcl_DStringAppend(resultPtr, "/", 1); + } + return winRootPatternPtr->endp[0]; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetPathType -- + * + * Determines whether a given path is relative to the current + * directory, relative to the current volume, or absolute. + * + * Results: + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_RELATIVE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_PathType +Tcl_GetPathType(path) + char *path; +{ + Tcl_PathType type = TCL_PATH_ABSOLUTE; + + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + /* + * Paths that begin with / or ~ are absolute. + */ + + if ((path[0] != '/') && (path[0] != '~')) { + type = TCL_PATH_RELATIVE; + } + break; + + case TCL_PLATFORM_MAC: + if (path[0] == ':') { + type = TCL_PATH_RELATIVE; + } else if (path[0] != '~') { + + /* + * Since we have eliminated the easy cases, use the + * root pattern to look for the other types. + */ + + if (!macRootPatternPtr) { + macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + if (!TclRegExec(macRootPatternPtr, path, path) + || (macRootPatternPtr->startp[2] != NULL)) { + type = TCL_PATH_RELATIVE; + } + } + break; + + case TCL_PLATFORM_WINDOWS: + if (path[0] != '~') { + + /* + * Since we have eliminated the easy cases, check for + * drive relative paths using the regular expression. + */ + + if (!winRootPatternPtr) { + winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + if (TclRegExec(winRootPatternPtr, path, path)) { + if (winRootPatternPtr->startp[5] + || (winRootPatternPtr->startp[2] + && !(winRootPatternPtr->startp[6]))) { + type = TCL_PATH_VOLUME_RELATIVE; + } + } else { + type = TCL_PATH_RELATIVE; + } + } + break; + } + return type; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SplitPath -- + * + * Split a path into a list of path components. The first element + * of the list will have the same path type as the original path. + * + * Results: + * Returns a standard Tcl result. The interpreter result contains + * a list of path components. + * *argvPtr will be filled in with the address of an array + * whose elements point to the elements of path, in order. + * *argcPtr will get filled in with the number of valid elements + * in the array. A single block of memory is dynamically allocated + * to hold both the argv array and a copy of the path elements. + * The caller must eventually free this memory by calling ckfree() + * on *argvPtr. Note: *argvPtr and *argcPtr are only modified + * if the procedure returns normally. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SplitPath(path, argcPtr, argvPtr) + char *path; /* Pointer to string containing a path. */ + int *argcPtr; /* Pointer to location to fill in with + * the number of elements in the path. */ + char ***argvPtr; /* Pointer to place to store pointer to array + * of pointers to path elements. */ +{ + int i, size; + char *p; + Tcl_DString buffer; + Tcl_DStringInit(&buffer); + + /* + * Perform platform specific splitting. These routines will leave the + * result in the specified buffer. Individual elements are terminated + * with a null character. + */ + + p = NULL; /* Needed only to prevent gcc warnings. */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + p = SplitUnixPath(path, &buffer); + break; + + case TCL_PLATFORM_WINDOWS: + p = SplitWinPath(path, &buffer); + break; + + case TCL_PLATFORM_MAC: + p = SplitMacPath(path, &buffer); + break; + } + + /* + * Compute the number of elements in the result. + */ + + size = Tcl_DStringLength(&buffer); + *argcPtr = 0; + for (i = 0; i < size; i++) { + if (p[i] == '\0') { + (*argcPtr)++; + } + } + + /* + * Allocate a buffer large enough to hold the contents of the + * DString plus the argv pointers and the terminating NULL pointer. + */ + + *argvPtr = (char **) ckalloc((unsigned) + ((((*argcPtr) + 1) * sizeof(char *)) + size)); + + /* + * Position p after the last argv pointer and copy the contents of + * the DString. + */ + + p = (char *) &(*argvPtr)[(*argcPtr) + 1]; + memcpy((VOID *) p, (VOID *) Tcl_DStringValue(&buffer), (size_t) size); + + /* + * Now set up the argv pointers. + */ + + for (i = 0; i < *argcPtr; i++) { + (*argvPtr)[i] = p; + while ((*p++) != '\0') {} + } + (*argvPtr)[i] = NULL; + + Tcl_DStringFree(&buffer); +} + +/* + *---------------------------------------------------------------------- + * + * SplitUnixPath -- + * + * This routine is used by Tcl_SplitPath to handle splitting + * Unix paths. + * + * Results: + * Stores a null separated array of strings in the specified + * Tcl_DString. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +SplitUnixPath(path, bufPtr) + char *path; /* Pointer to string containing a path. */ + Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ +{ + int length; + char *p, *elementStart; + + /* + * Deal with the root directory as a special case. + */ + + if (path[0] == '/') { + Tcl_DStringAppend(bufPtr, "/", 2); + p = path+1; + } else { + p = path; + } + + /* + * Split on slashes. Embedded elements that start with tilde will be + * prefixed with "./" so they are not affected by tilde substitution. + */ + + for (;;) { + elementStart = p; + while ((*p != '\0') && (*p != '/')) { + p++; + } + length = p - elementStart; + if (length > 0) { + if ((elementStart[0] == '~') && (elementStart != path)) { + Tcl_DStringAppend(bufPtr, "./", 2); + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + } + if (*p++ == '\0') { + break; + } + } + return Tcl_DStringValue(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SplitWinPath -- + * + * This routine is used by Tcl_SplitPath to handle splitting + * Windows paths. + * + * Results: + * Stores a null separated array of strings in the specified + * Tcl_DString. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +SplitWinPath(path, bufPtr) + char *path; /* Pointer to string containing a path. */ + Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ +{ + int length; + char *p, *elementStart; + + p = ExtractWinRoot(path, bufPtr, 0); + + /* + * Terminate the root portion, if we matched something. + */ + + if (p != path) { + Tcl_DStringAppend(bufPtr, "", 1); + } + + /* + * Split on slashes. Embedded elements that start with tilde will be + * prefixed with "./" so they are not affected by tilde substitution. + */ + + do { + elementStart = p; + while ((*p != '\0') && (*p != '/') && (*p != '\\')) { + p++; + } + length = p - elementStart; + if (length > 0) { + if ((elementStart[0] == '~') && (elementStart != path)) { + Tcl_DStringAppend(bufPtr, "./", 2); + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + } + } while (*p++ != '\0'); + + return Tcl_DStringValue(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SplitMacPath -- + * + * This routine is used by Tcl_SplitPath to handle splitting + * Macintosh paths. + * + * Results: + * Returns a newly allocated argv array. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +SplitMacPath(path, bufPtr) + char *path; /* Pointer to string containing a path. */ + Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ +{ + int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */ + int i, length; + char *p, *elementStart; + + /* + * Initialize the path name parser for Macintosh path names. + */ + + if (macRootPatternPtr == NULL) { + macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + + /* + * Match the root portion of a Mac path name. + */ + + i = 0; /* Needed only to prevent gcc warnings. */ + if (TclRegExec(macRootPatternPtr, path, path) == 1) { + /* + * Treat degenerate absolute paths like / and /../.. as + * Mac relative file names for lack of anything else to do. + */ + + if (macRootPatternPtr->startp[2] != NULL) { + Tcl_DStringAppend(bufPtr, ":", 1); + Tcl_DStringAppend(bufPtr, path, macRootPatternPtr->endp[0] + - macRootPatternPtr->startp[0] + 1); + return Tcl_DStringValue(bufPtr); + } + + if (macRootPatternPtr->startp[5] != NULL) { + + /* + * Unix-style tilde prefixed paths. + */ + + isMac = 0; + i = 5; + } else if (macRootPatternPtr->startp[7] != NULL) { + + /* + * Mac-style tilde prefixed paths. + */ + + isMac = 1; + i = 7; + } else if (macRootPatternPtr->startp[10] != NULL) { + + /* + * Normal Unix style paths. + */ + + isMac = 0; + i = 10; + } else if (macRootPatternPtr->startp[12] != NULL) { + + /* + * Normal Mac style paths. + */ + + isMac = 1; + i = 12; + } + + length = macRootPatternPtr->endp[i] + - macRootPatternPtr->startp[i]; + + /* + * Append the element and terminate it with a : and a null. Note that + * we are forcing the DString to contain an extra null at the end. + */ + + Tcl_DStringAppend(bufPtr, macRootPatternPtr->startp[i], length); + Tcl_DStringAppend(bufPtr, ":", 2); + p = macRootPatternPtr->endp[i]; + } else { + isMac = (strchr(path, ':') != NULL); + p = path; + } + + if (isMac) { + + /* + * p is pointing at the first colon in the path. There + * will always be one, since this is a Mac-style path. + */ + + elementStart = p++; + while ((p = strchr(p, ':')) != NULL) { + length = p - elementStart; + if (length == 1) { + while (*p == ':') { + Tcl_DStringAppend(bufPtr, "::", 3); + elementStart = p++; + } + } else { + /* + * If this is a simple component, drop the leading colon. + */ + + if ((elementStart[1] != '~') + && (strchr(elementStart+1, '/') == NULL)) { + elementStart++; + length--; + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + elementStart = p++; + } + } + if (elementStart[1] != '\0' || elementStart == path) { + if ((elementStart[1] != '~') && (elementStart[1] != '\0') + && (strchr(elementStart+1, '/') == NULL)) { + elementStart++; + } + Tcl_DStringAppend(bufPtr, elementStart, -1); + Tcl_DStringAppend(bufPtr, "", 1); + } + } else { + + /* + * Split on slashes, suppress extra /'s, and convert .. to ::. + */ + + for (;;) { + elementStart = p; + while ((*p != '\0') && (*p != '/')) { + p++; + } + length = p - elementStart; + if (length > 0) { + if ((length == 1) && (elementStart[0] == '.')) { + Tcl_DStringAppend(bufPtr, ":", 2); + } else if ((length == 2) && (elementStart[0] == '.') + && (elementStart[1] == '.')) { + Tcl_DStringAppend(bufPtr, "::", 3); + } else { + if (*elementStart == '~') { + Tcl_DStringAppend(bufPtr, ":", 1); + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + } + } + if (*p++ == '\0') { + break; + } + } + } + return Tcl_DStringValue(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_JoinPath -- + * + * Combine a list of paths in a platform specific manner. + * + * Results: + * Appends the joined path to the end of the specified + * returning a pointer to the resulting string. Note that + * the Tcl_DString must already be initialized. + * + * Side effects: + * Modifies the Tcl_DString. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_JoinPath(argc, argv, resultPtr) + int argc; + char **argv; + Tcl_DString *resultPtr; /* Pointer to previously initialized DString. */ +{ + int oldLength, length, i, needsSep; + Tcl_DString buffer; + char *p, c, *dest; + + Tcl_DStringInit(&buffer); + oldLength = Tcl_DStringLength(resultPtr); + + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + for (i = 0; i < argc; i++) { + p = argv[i]; + /* + * If the path is absolute, reset the result buffer. + * Consume any duplicate leading slashes or a ./ in + * front of a tilde prefixed path that isn't at the + * beginning of the path. + */ + + if (*p == '/') { + Tcl_DStringSetLength(resultPtr, oldLength); + Tcl_DStringAppend(resultPtr, "/", 1); + while (*p == '/') { + p++; + } + } else if (*p == '~') { + Tcl_DStringSetLength(resultPtr, oldLength); + } else if ((Tcl_DStringLength(resultPtr) != oldLength) + && (p[0] == '.') && (p[1] == '/') + && (p[2] == '~')) { + p += 2; + } + + if (*p == '\0') { + continue; + } + + /* + * Append a separator if needed. + */ + + length = Tcl_DStringLength(resultPtr); + if ((length != oldLength) + && (Tcl_DStringValue(resultPtr)[length-1] != '/')) { + Tcl_DStringAppend(resultPtr, "/", 1); + length++; + } + + /* + * Append the element, eliminating duplicate and trailing + * slashes. + */ + + Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p))); + dest = Tcl_DStringValue(resultPtr) + length; + for (; *p != '\0'; p++) { + if (*p == '/') { + while (p[1] == '/') { + p++; + } + if (p[1] != '\0') { + *dest++ = '/'; + } + } else { + *dest++ = *p; + } + } + length = dest - Tcl_DStringValue(resultPtr); + Tcl_DStringSetLength(resultPtr, length); + } + break; + + case TCL_PLATFORM_WINDOWS: + /* + * Iterate over all of the components. If a component is + * absolute, then reset the result and start building the + * path from the current component on. + */ + + for (i = 0; i < argc; i++) { + p = ExtractWinRoot(argv[i], resultPtr, oldLength); + length = Tcl_DStringLength(resultPtr); + + /* + * If the pointer didn't move, then this is a relative path + * or a tilde prefixed path. + */ + + if (p == argv[i]) { + /* + * Remove the ./ from tilde prefixed elements unless + * it is the first component. + */ + + if ((length != oldLength) + && (p[0] == '.') + && ((p[1] == '/') || (p[1] == '\\')) + && (p[2] == '~')) { + p += 2; + } else if (*p == '~') { + Tcl_DStringSetLength(resultPtr, oldLength); + length = oldLength; + } + } + + if (*p != '\0') { + /* + * Check to see if we need to append a separator. + */ + + + if (length != oldLength) { + c = Tcl_DStringValue(resultPtr)[length-1]; + if ((c != '/') && (c != ':')) { + Tcl_DStringAppend(resultPtr, "/", 1); + } + } + + /* + * Append the element, eliminating duplicate and + * trailing slashes. + */ + + length = Tcl_DStringLength(resultPtr); + Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p))); + dest = Tcl_DStringValue(resultPtr) + length; + for (; *p != '\0'; p++) { + if ((*p == '/') || (*p == '\\')) { + while ((p[1] == '/') || (p[1] == '\\')) { + p++; + } + if (p[1] != '\0') { + *dest++ = '/'; + } + } else { + *dest++ = *p; + } + } + length = dest - Tcl_DStringValue(resultPtr); + Tcl_DStringSetLength(resultPtr, length); + } + } + break; + + case TCL_PLATFORM_MAC: + needsSep = 1; + for (i = 0; i < argc; i++) { + Tcl_DStringSetLength(&buffer, 0); + p = SplitMacPath(argv[i], &buffer); + if ((*p != ':') && (*p != '\0') + && (strchr(p, ':') != NULL)) { + Tcl_DStringSetLength(resultPtr, oldLength); + length = strlen(p); + Tcl_DStringAppend(resultPtr, p, length); + needsSep = 0; + p += length+1; + } + + /* + * Now append the rest of the path elements, skipping + * : unless it is the first element of the path, and + * watching out for :: et al. so we don't end up with + * too many colons in the result. + */ + + for (; *p != '\0'; p += length+1) { + if (p[0] == ':' && p[1] == '\0') { + if (Tcl_DStringLength(resultPtr) != oldLength) { + p++; + } else { + needsSep = 0; + } + } else { + c = p[1]; + if (*p == ':') { + if (!needsSep) { + p++; + } + } else { + if (needsSep) { + Tcl_DStringAppend(resultPtr, ":", 1); + } + } + needsSep = (c == ':') ? 0 : 1; + } + length = strlen(p); + Tcl_DStringAppend(resultPtr, p, length); + } + } + break; + + } + Tcl_DStringFree(&buffer); + return Tcl_DStringValue(resultPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TranslateFileName -- + * + * Converts a file name into a form usable by the native system + * interfaces. If the name starts with a tilde, it will produce + * a name where the tilde and following characters have been + * replaced by the home directory location for the named user. + * + * Results: + * The result is a pointer to a static string containing + * the new name. If there was an error in processing the + * name, then an error message is left in interp->result + * and the return value is NULL. The result will be stored + * in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr) + * to free the name if the return value was not NULL. + * + * Side effects: + * Information may be left in bufferPtr. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_TranslateFileName(interp, name, bufferPtr) + Tcl_Interp *interp; /* Interpreter in which to store error + * message (if necessary). */ + char *name; /* File name, which may begin with "~" + * (to indicate current user's home directory) + * or "~<user>" (to indicate any user's + * home directory). */ + Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold + * anything at the time of the call, and need + * not even be initialized. */ +{ + register char *p; + + /* + * Handle tilde substitutions, if needed. + */ + + if (name[0] == '~') { + int argc, length; + char **argv; + Tcl_DString temp; + + Tcl_SplitPath(name, &argc, &argv); + + /* + * Strip the trailing ':' off of a Mac path + * before passing the user name to DoTildeSubst. + */ + + if (tclPlatform == TCL_PLATFORM_MAC) { + length = strlen(argv[0]); + argv[0][length-1] = '\0'; + } + + Tcl_DStringInit(&temp); + argv[0] = DoTildeSubst(interp, argv[0]+1, &temp); + if (argv[0] == NULL) { + Tcl_DStringFree(&temp); + ckfree((char *)argv); + return NULL; + } + Tcl_DStringInit(bufferPtr); + Tcl_JoinPath(argc, argv, bufferPtr); + Tcl_DStringFree(&temp); + ckfree((char*)argv); + } else { + Tcl_DStringInit(bufferPtr); + Tcl_JoinPath(1, &name, bufferPtr); + } + + /* + * Convert forward slashes to backslashes in Windows paths because + * some system interfaces don't accept forward slashes. + */ + + if (tclPlatform == TCL_PLATFORM_WINDOWS) { + for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { + if (*p == '/') { + *p = '\\'; + } + } + } + return Tcl_DStringValue(bufferPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetExtension -- + * + * This function returns a pointer to the beginning of the + * extension part of a file name. + * + * Results: + * Returns a pointer into name which indicates where the extension + * starts. If there is no extension, returns NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetExtension(name) + char *name; /* File name to parse. */ +{ + char *p, *lastSep; + + /* + * First find the last directory separator. + */ + + lastSep = NULL; /* Needed only to prevent gcc warnings. */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + lastSep = strrchr(name, '/'); + break; + + case TCL_PLATFORM_MAC: + if (strchr(name, ':') == NULL) { + lastSep = strrchr(name, '/'); + } else { + lastSep = strrchr(name, ':'); + } + break; + + case TCL_PLATFORM_WINDOWS: + lastSep = NULL; + for (p = name; *p != '\0'; p++) { + if (strchr("/\\:", *p) != NULL) { + lastSep = p; + } + } + break; + } + p = strrchr(name, '.'); + if ((p != NULL) && (lastSep != NULL) + && (lastSep > p)) { + p = NULL; + } + + /* + * Back up to the first period in a series of contiguous dots. + * This is needed so foo..o will be split on the first dot. + */ + + if (p != NULL) { + while ((p > name) && *(p-1) == '.') { + p--; + } + } + return p; +} + +/* + *---------------------------------------------------------------------- + * + * DoTildeSubst -- + * + * Given a string following a tilde, this routine returns the + * corresponding home directory. + * + * Results: + * The result is a pointer to a static string containing the home + * directory in native format. If there was an error in processing + * the substitution, then an error message is left in interp->result + * and the return value is NULL. On success, the results are appended + * to resultPtr, and the contents of resultPtr are returned. + * + * Side effects: + * Information may be left in resultPtr. + * + *---------------------------------------------------------------------- + */ + +static char * +DoTildeSubst(interp, user, resultPtr) + Tcl_Interp *interp; /* Interpreter in which to store error + * message (if necessary). */ + char *user; /* Name of user whose home directory should be + * substituted, or "" for current user. */ + Tcl_DString *resultPtr; /* May be used to hold result. Must not hold + * anything at the time of the call, and need + * not even be initialized. */ +{ + char *dir; + + if (*user == '\0') { + dir = TclGetEnv("HOME"); + if (dir == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't find HOME environment ", + "variable to expand path", (char *) NULL); + } + return NULL; + } + Tcl_JoinPath(1, &dir, resultPtr); + } else { + + /* lint, TclGetuserHome() always NULL under windows. */ + if (TclGetUserHome(user, resultPtr) == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", + (char *) NULL); + } + return NULL; + } + } + return resultPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobCmd -- + * + * This procedure is invoked to process the "glob" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_GlobCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, noComplain, firstArg; + char c; + int result = TCL_OK; + Tcl_DString buffer; + char *separators, *head, *tail; + + noComplain = 0; + for (firstArg = 1; (firstArg < argc) && (argv[firstArg][0] == '-'); + firstArg++) { + if (strcmp(argv[firstArg], "-nocomplain") == 0) { + noComplain = 1; + } else if (strcmp(argv[firstArg], "--") == 0) { + firstArg++; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argv[firstArg], + "\": must be -nocomplain or --", (char *) NULL); + return TCL_ERROR; + } + } + if (firstArg >= argc) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? name ?name ...?\"", (char *) NULL); + return TCL_ERROR; + } + + Tcl_DStringInit(&buffer); + separators = NULL; /* Needed only to prevent gcc warnings. */ + for (i = firstArg; i < argc; i++) { + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separators = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separators = "/\\:"; + break; + case TCL_PLATFORM_MAC: + separators = (strchr(argv[i], ':') == NULL) ? "/" : ":"; + break; + } + + Tcl_DStringSetLength(&buffer, 0); + + /* + * Perform tilde substitution, if needed. + */ + + if (argv[i][0] == '~') { + char *p; + + /* + * Find the first path separator after the tilde. + */ + + for (tail = argv[i]; *tail != '\0'; tail++) { + if (*tail == '\\') { + if (strchr(separators, tail[1]) != NULL) { + break; + } + } else if (strchr(separators, *tail) != NULL) { + break; + } + } + + /* + * Determine the home directory for the specified user. Note that + * we don't allow special characters in the user name. + */ + + c = *tail; + *tail = '\0'; + p = strpbrk(argv[i]+1, "\\[]*?{}"); + if (p == NULL) { + head = DoTildeSubst(interp, argv[i]+1, &buffer); + } else { + if (!noComplain) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "globbing characters not ", + "supported in user names", (char *) NULL); + } + head = NULL; + } + *tail = c; + if (head == NULL) { + if (noComplain) { + Tcl_ResetResult(interp); + continue; + } else { + result = TCL_ERROR; + goto done; + } + } + if (head != Tcl_DStringValue(&buffer)) { + Tcl_DStringAppend(&buffer, head, -1); + } + } else { + tail = argv[i]; + } + + result = TclDoGlob(interp, separators, &buffer, tail); + if (result != TCL_OK) { + if (noComplain) { + /* + * We should in fact pass down the nocomplain flag + * or save the interp result or use another mecanism + * so the interp result is not mangled on errors in that case. + * but that would a bigger change than reasonable for a patch + * release. + * (see fileName.test 15.2-15.4 for expected behaviour) + */ + Tcl_ResetResult(interp); + result = TCL_OK; + continue; + } else { + goto done; + } + } + } + + if ((*interp->result == 0) && !noComplain) { + char *sep = ""; + + Tcl_AppendResult(interp, "no files matched glob pattern", + (argc == 2) ? " \"" : "s \"", (char *) NULL); + for (i = firstArg; i < argc; i++) { + Tcl_AppendResult(interp, sep, argv[i], (char *) NULL); + sep = " "; + } + Tcl_AppendResult(interp, "\"", (char *) NULL); + result = TCL_ERROR; + } +done: + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SkipToChar -- + * + * This function traverses a glob pattern looking for the next + * unquoted occurance of the specified character at the same braces + * nesting level. + * + * Results: + * Updates stringPtr to point to the matching character, or to + * the end of the string if nothing matched. The return value + * is 1 if a match was found at the top level, otherwise it is 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SkipToChar(stringPtr, match) + char **stringPtr; /* Pointer string to check. */ + char *match; /* Pointer to character to find. */ +{ + int quoted, level; + register char *p; + + quoted = 0; + level = 0; + + for (p = *stringPtr; *p != '\0'; p++) { + if (quoted) { + quoted = 0; + continue; + } + if ((level == 0) && (*p == *match)) { + *stringPtr = p; + return 1; + } + if (*p == '{') { + level++; + } else if (*p == '}') { + level--; + } else if (*p == '\\') { + quoted = 1; + } + } + *stringPtr = p; + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclDoGlob -- + * + * This recursive procedure forms the heart of the globbing + * code. It performs a depth-first traversal of the tree + * given by the path name to be globbed. The directory and + * remainder are assumed to be native format paths. + * + * Results: + * The return value is a standard Tcl result indicating whether + * an error occurred in globbing. After a normal return the + * result in interp will be set to hold all of the file names + * given by the dir and rem arguments. After an error the + * result in interp will hold an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclDoGlob(interp, separators, headPtr, tail) + Tcl_Interp *interp; /* Interpreter to use for error reporting + * (e.g. unmatched brace). */ + char *separators; /* String containing separator characters + * that should be used to identify globbing + * boundaries. */ + Tcl_DString *headPtr; /* Completely expanded prefix. */ + char *tail; /* The unexpanded remainder of the path. */ +{ + int baseLength, quoted, count; + int result = TCL_OK; + char *p, *openBrace, *closeBrace, *name, *firstSpecialChar, savedChar; + char lastChar = 0; + int length = Tcl_DStringLength(headPtr); + + if (length > 0) { + lastChar = Tcl_DStringValue(headPtr)[length-1]; + } + + /* + * Consume any leading directory separators, leaving tail pointing + * just past the last initial separator. + */ + + count = 0; + name = tail; + for (; *tail != '\0'; tail++) { + if ((*tail == '\\') && (strchr(separators, tail[1]) != NULL)) { + tail++; + } else if (strchr(separators, *tail) == NULL) { + break; + } + count++; + } + + /* + * Deal with path separators. On the Mac, we have to watch out + * for multiple separators, since they are special in Mac-style + * paths. + */ + + switch (tclPlatform) { + case TCL_PLATFORM_MAC: + if (*separators == '/') { + if (((length == 0) && (count == 0)) + || ((length > 0) && (lastChar != ':'))) { + Tcl_DStringAppend(headPtr, ":", 1); + } + } else { + if (count == 0) { + if ((length > 0) && (lastChar != ':')) { + Tcl_DStringAppend(headPtr, ":", 1); + } + } else { + if (lastChar == ':') { + count--; + } + while (count-- > 0) { + Tcl_DStringAppend(headPtr, ":", 1); + } + } + } + break; + case TCL_PLATFORM_WINDOWS: + /* + * If this is a drive relative path, add the colon and the + * trailing slash if needed. Otherwise add the slash if + * this is the first absolute element, or a later relative + * element. Add an extra slash if this is a UNC path. + */ + + if (*name == ':') { + Tcl_DStringAppend(headPtr, ":", 1); + if (count > 1) { + Tcl_DStringAppend(headPtr, "/", 1); + } + } else if ((*tail != '\0') + && (((length > 0) + && (strchr(separators, lastChar) == NULL)) + || ((length == 0) && (count > 0)))) { + Tcl_DStringAppend(headPtr, "/", 1); + if ((length == 0) && (count > 1)) { + Tcl_DStringAppend(headPtr, "/", 1); + } + } + + break; + case TCL_PLATFORM_UNIX: + /* + * Add a separator if this is the first absolute element, or + * a later relative element. + */ + + if ((*tail != '\0') + && (((length > 0) + && (strchr(separators, lastChar) == NULL)) + || ((length == 0) && (count > 0)))) { + Tcl_DStringAppend(headPtr, "/", 1); + } + break; + } + + /* + * Look for the first matching pair of braces or the first + * directory separator that is not inside a pair of braces. + */ + + openBrace = closeBrace = NULL; + quoted = 0; + for (p = tail; *p != '\0'; p++) { + if (quoted) { + quoted = 0; + } else if (*p == '\\') { + quoted = 1; + if (strchr(separators, p[1]) != NULL) { + break; /* Quoted directory separator. */ + } + } else if (strchr(separators, *p) != NULL) { + break; /* Unquoted directory separator. */ + } else if (*p == '{') { + openBrace = p; + p++; + if (SkipToChar(&p, "}")) { + closeBrace = p; /* Balanced braces. */ + break; + } + Tcl_SetResult(interp, "unmatched open-brace in file name", + TCL_STATIC); + return TCL_ERROR; + } else if (*p == '}') { + Tcl_SetResult(interp, "unmatched close-brace in file name", + TCL_STATIC); + return TCL_ERROR; + } + } + + /* + * Substitute the alternate patterns from the braces and recurse. + */ + + if (openBrace != NULL) { + char *element; + Tcl_DString newName; + Tcl_DStringInit(&newName); + + /* + * For each element within in the outermost pair of braces, + * append the element and the remainder to the fixed portion + * before the first brace and recursively call TclDoGlob. + */ + + Tcl_DStringAppend(&newName, tail, openBrace-tail); + baseLength = Tcl_DStringLength(&newName); + length = Tcl_DStringLength(headPtr); + *closeBrace = '\0'; + for (p = openBrace; p != closeBrace; ) { + p++; + element = p; + SkipToChar(&p, ","); + Tcl_DStringSetLength(headPtr, length); + Tcl_DStringSetLength(&newName, baseLength); + Tcl_DStringAppend(&newName, element, p-element); + Tcl_DStringAppend(&newName, closeBrace+1, -1); + result = TclDoGlob(interp, separators, + headPtr, Tcl_DStringValue(&newName)); + if (result != TCL_OK) { + break; + } + } + *closeBrace = '}'; + Tcl_DStringFree(&newName); + return result; + } + + /* + * At this point, there are no more brace substitutions to perform on + * this path component. The variable p is pointing at a quoted or + * unquoted directory separator or the end of the string. So we need + * to check for special globbing characters in the current pattern. + * We avoid modifying tail if p is pointing at the end of the string. + */ + + if (*p != '\0') { + savedChar = *p; + *p = '\0'; + firstSpecialChar = strpbrk(tail, "*[]?\\"); + *p = savedChar; + } else { + firstSpecialChar = strpbrk(tail, "*[]?\\"); + } + + if (firstSpecialChar != NULL) { + /* + * Look for matching files in the current directory. The + * implementation of this function is platform specific, but may + * recursively call TclDoGlob. For each file that matches, it will + * add the match onto the interp->result, or call TclDoGlob if there + * are more characters to be processed. + */ + + return TclMatchFiles(interp, separators, headPtr, tail, p); + } + Tcl_DStringAppend(headPtr, tail, p-tail); + if (*p != '\0') { + return TclDoGlob(interp, separators, headPtr, p); + } + + /* + * There are no more wildcards in the pattern and no more unprocessed + * characters in the tail, so now we can construct the path and verify + * the existence of the file. + */ + + switch (tclPlatform) { + case TCL_PLATFORM_MAC: + if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) { + Tcl_DStringAppend(headPtr, ":", 1); + } + name = Tcl_DStringValue(headPtr); + if (TclAccess(name, F_OK) == 0) { + if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) { + Tcl_AppendElement(interp, name+1); + } else { + Tcl_AppendElement(interp, name); + } + } + break; + case TCL_PLATFORM_WINDOWS: { + int exists; + /* + * We need to convert slashes to backslashes before checking + * for the existence of the file. Once we are done, we need + * to convert the slashes back. + */ + + if (Tcl_DStringLength(headPtr) == 0) { + if (((*name == '\\') && (name[1] == '/' || name[1] == '\\')) + || (*name == '/')) { + Tcl_DStringAppend(headPtr, "\\", 1); + } else { + Tcl_DStringAppend(headPtr, ".", 1); + } + } else { + for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) { + if (*p == '/') { + *p = '\\'; + } + } + } + name = Tcl_DStringValue(headPtr); + exists = (TclAccess(name, F_OK) == 0); + for (p = name; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + if (exists) { + Tcl_AppendElement(interp, name); + } + break; + } + case TCL_PLATFORM_UNIX: + if (Tcl_DStringLength(headPtr) == 0) { + if ((*name == '\\' && name[1] == '/') || (*name == '/')) { + Tcl_DStringAppend(headPtr, "/", 1); + } else { + Tcl_DStringAppend(headPtr, ".", 1); + } + } + name = Tcl_DStringValue(headPtr); + if (TclAccess(name, F_OK) == 0) { + Tcl_AppendElement(interp, name); + } + break; + } + + return TCL_OK; +} diff --git a/tcl/generic/tclGet.c b/tcl/generic/tclGet.c new file mode 100644 index 00000000000..e426cf59df9 --- /dev/null +++ b/tcl/generic/tclGet.c @@ -0,0 +1,328 @@ +/* + * tclGet.c -- + * + * This file contains procedures to convert strings into + * other forms, like integers or floating-point numbers or + * booleans, doing syntax checking along the way. + * + * Copyright (c) 1990-1993 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetInt -- + * + * Given a string, produce the corresponding integer value. + * + * Results: + * The return value is normally TCL_OK; in this case *intPtr + * will be set to the integer value equivalent to string. If + * string is improperly formed then TCL_ERROR is returned and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetInt(interp, string, intPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + char *string; /* String containing a (possibly signed) + * integer in a form acceptable to strtol. */ + int *intPtr; /* Place to store converted result. */ +{ + char *end, *p; + long i; + + /* + * Note: use strtoul instead of strtol for integer conversions + * to allow full-size unsigned numbers, but don't depend on strtoul + * to handle sign characters; it won't in some implementations. + */ + + errno = 0; + for (p = string; isspace(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + if (*p == '-') { + p++; + i = -((long)strtoul(p, &end, 0)); + } else if (*p == '+') { + p++; + i = strtoul(p, &end, 0); + } else { + i = strtoul(p, &end, 0); + } + if (end == p) { + badInteger: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "expected integer but got \"", string, + "\"", (char *) NULL); + } + return TCL_ERROR; + } + + /* + * The second test below is needed on platforms where "long" is + * larger than "int" to detect values that fit in a long but not in + * an int. + */ + + if ((errno == ERANGE) || (((long)(int) i) != i)) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_SetResult(interp, "integer value too large to represent", + TCL_STATIC); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + } + return TCL_ERROR; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if (*end != 0) { + goto badInteger; + } + *intPtr = (int) i; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetLong -- + * + * Given a string, produce the corresponding long integer value. + * This routine is a version of Tcl_GetInt but returns a "long" + * instead of an "int". + * + * Results: + * The return value is normally TCL_OK; in this case *longPtr + * will be set to the long integer value equivalent to string. If + * string is improperly formed then TCL_ERROR is returned and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetLong(interp, string, longPtr) + Tcl_Interp *interp; /* Interpreter used for error reporting. */ + char *string; /* String containing a (possibly signed) + * long integer in a form acceptable to + * strtoul. */ + long *longPtr; /* Place to store converted long result. */ +{ + char *end, *p; + long i; + + /* + * Note: don't depend on strtoul to handle sign characters; it won't + * in some implementations. + */ + + errno = 0; + for (p = string; isspace(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + if (*p == '-') { + p++; + i = -(int)strtoul(p, &end, 0); + } else if (*p == '+') { + p++; + i = strtoul(p, &end, 0); + } else { + i = strtoul(p, &end, 0); + } + if (end == p) { + badInteger: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "expected integer but got \"", string, + "\"", (char *) NULL); + } + return TCL_ERROR; + } + if (errno == ERANGE) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_SetResult(interp, "integer value too large to represent", + TCL_STATIC); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + } + return TCL_ERROR; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if (*end != 0) { + goto badInteger; + } + *longPtr = i; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetDouble -- + * + * Given a string, produce the corresponding double-precision + * floating-point value. + * + * Results: + * The return value is normally TCL_OK; in this case *doublePtr + * will be set to the double-precision value equivalent to string. + * If string is improperly formed then TCL_ERROR is returned and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetDouble(interp, string, doublePtr) + Tcl_Interp *interp; /* Interpreter used for error reporting. */ + char *string; /* String containing a floating-point number + * in a form acceptable to strtod. */ + double *doublePtr; /* Place to store converted result. */ +{ + char *end; + double d; + + errno = 0; + d = strtod(string, &end); + if (end == string) { + badDouble: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "expected floating-point number but got \"", + string, "\"", (char *) NULL); + } + return TCL_ERROR; + } + if (errno != 0) { + if (interp != (Tcl_Interp *) NULL) { + TclExprFloatError(interp, d); /* sets interp->objResult */ + + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), + (int *) NULL), + TCL_VOLATILE); + } + return TCL_ERROR; + } + while ((*end != 0) && isspace(UCHAR(*end))) { + end++; + } + if (*end != 0) { + goto badDouble; + } + *doublePtr = d; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetBoolean -- + * + * Given a string, return a 0/1 boolean value corresponding + * to the string. + * + * Results: + * The return value is normally TCL_OK; in this case *boolPtr + * will be set to the 0/1 value equivalent to string. If + * string is improperly formed then TCL_ERROR is returned and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetBoolean(interp, string, boolPtr) + Tcl_Interp *interp; /* Interpreter used for error reporting. */ + char *string; /* String containing a boolean number + * specified either as 1/0 or true/false or + * yes/no. */ + int *boolPtr; /* Place to store converted result, which + * will be 0 or 1. */ +{ + int i; + char lowerCase[10], c; + size_t length; + + /* + * Convert the input string to all lower-case. + */ + + for (i = 0; i < 9; i++) { + c = string[i]; + if (c == 0) { + break; + } + if ((c >= 'A') && (c <= 'Z')) { + c += (char) ('a' - 'A'); + } + lowerCase[i] = c; + } + lowerCase[i] = 0; + + length = strlen(lowerCase); + c = lowerCase[0]; + if ((c == '0') && (lowerCase[1] == '\0')) { + *boolPtr = 0; + } else if ((c == '1') && (lowerCase[1] == '\0')) { + *boolPtr = 1; + } else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) { + *boolPtr = 1; + } else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) { + *boolPtr = 0; + } else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) { + *boolPtr = 1; + } else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) { + *boolPtr = 0; + } else if ((c == 'o') && (length >= 2)) { + if (strncmp(lowerCase, "on", length) == 0) { + *boolPtr = 1; + } else if (strncmp(lowerCase, "off", length) == 0) { + *boolPtr = 0; + } else { + goto badBoolean; + } + } else { + badBoolean: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "expected boolean value but got \"", + string, "\"", (char *) NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} diff --git a/tcl/generic/tclGetDate.y b/tcl/generic/tclGetDate.y new file mode 100644 index 00000000000..f8b6ca29eab --- /dev/null +++ b/tcl/generic/tclGetDate.y @@ -0,0 +1,958 @@ +/* + * tclGetDate.y -- + * + * Contains yacc grammar for parsing date and time strings. + * The output of this file should be the file tclDate.c which + * is used directly in the Tcl sources. + * + * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. + * Copyright (c) 1995-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. + * + * RCS: @(#) $Id$ + */ + +%{ +/* + * tclDate.c -- + * + * This file is generated from a yacc grammar defined in + * the file tclGetDate.y. It should not be edited directly. + * + * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. + * Copyright (c) 1995-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. + * + * SCCSID + */ + +#include "tclInt.h" +#include "tclPort.h" + +#ifdef MAC_TCL +# define EPOCH 1904 +# define START_OF_TIME 1904 +# define END_OF_TIME 2039 +#else +# define EPOCH 1970 +# define START_OF_TIME 1902 +# define END_OF_TIME 2037 +#endif + +/* + * The offset of tm_year of struct tm returned by localtime, gmtime, etc. + * I don't know how universal this is; K&R II, the NetBSD manpages, and + * ../compat/strftime.c all agree that tm_year is the year-1900. However, + * some systems may have a different value. This #define should be the + * same as in ../compat/strftime.c. + */ +#define TM_YEAR_BASE 1900 + +#define HOUR(x) ((int) (60 * x)) +#define SECSPERDAY (24L * 60L * 60L) + + +/* + * An entry in the lexical lookup table. + */ +typedef struct _TABLE { + char *name; + int type; + time_t value; +} TABLE; + + +/* + * Daylight-savings mode: on, off, or not yet known. + */ +typedef enum _DSTMODE { + DSTon, DSToff, DSTmaybe +} DSTMODE; + +/* + * Meridian: am, pm, or 24-hour style. + */ +typedef enum _MERIDIAN { + MERam, MERpm, MER24 +} MERIDIAN; + + +/* + * Global variables. We could get rid of most of these by using a good + * union as the yacc stack. (This routine was originally written before + * yacc had the %union construct.) Maybe someday; right now we only use + * the %union very rarely. + */ +static char *yyInput; +static DSTMODE yyDSTmode; +static time_t yyDayOrdinal; +static time_t yyDayNumber; +static int yyHaveDate; +static int yyHaveDay; +static int yyHaveRel; +static int yyHaveTime; +static int yyHaveZone; +static time_t yyTimezone; +static time_t yyDay; +static time_t yyHour; +static time_t yyMinutes; +static time_t yyMonth; +static time_t yySeconds; +static time_t yyYear; +static MERIDIAN yyMeridian; +static time_t yyRelMonth; +static time_t yyRelSeconds; + + +/* + * Prototypes of internal functions. + */ +static void yyerror _ANSI_ARGS_((char *s)); +static time_t ToSeconds _ANSI_ARGS_((time_t Hours, time_t Minutes, + time_t Seconds, MERIDIAN Meridian)); +static int Convert _ANSI_ARGS_((time_t Month, time_t Day, time_t Year, + time_t Hours, time_t Minutes, time_t Seconds, + MERIDIAN Meridia, DSTMODE DSTmode, time_t *TimePtr)); +static time_t DSTcorrect _ANSI_ARGS_((time_t Start, time_t Future)); +static time_t RelativeDate _ANSI_ARGS_((time_t Start, time_t DayOrdinal, + time_t DayNumber)); +static int RelativeMonth _ANSI_ARGS_((time_t Start, time_t RelMonth, + time_t *TimePtr)); +static int LookupWord _ANSI_ARGS_((char *buff)); +static int yylex _ANSI_ARGS_((void)); + +int +yyparse _ANSI_ARGS_((void)); +%} + +%union { + time_t Number; + enum _MERIDIAN Meridian; +} + +%token tAGO tDAY tDAYZONE tID tMERIDIAN tMINUTE_UNIT tMONTH tMONTH_UNIT +%token tSEC_UNIT tSNUMBER tUNUMBER tZONE tEPOCH tDST + +%type <Number> tDAY tDAYZONE tMINUTE_UNIT tMONTH tMONTH_UNIT tDST +%type <Number> tSEC_UNIT tSNUMBER tUNUMBER tZONE +%type <Meridian> tMERIDIAN o_merid + +%% + +spec : /* NULL */ + | spec item + ; + +item : time { + yyHaveTime++; + } + | zone { + yyHaveZone++; + } + | date { + yyHaveDate++; + } + | day { + yyHaveDay++; + } + | rel { + yyHaveRel++; + } + | number + ; + +time : tUNUMBER tMERIDIAN { + yyHour = $1; + yyMinutes = 0; + yySeconds = 0; + yyMeridian = $2; + } + | tUNUMBER ':' tUNUMBER o_merid { + yyHour = $1; + yyMinutes = $3; + yySeconds = 0; + yyMeridian = $4; + } + | tUNUMBER ':' tUNUMBER tSNUMBER { + yyHour = $1; + yyMinutes = $3; + yyMeridian = MER24; + yyDSTmode = DSToff; + yyTimezone = - ($4 % 100 + ($4 / 100) * 60); + } + | tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid { + yyHour = $1; + yyMinutes = $3; + yySeconds = $5; + yyMeridian = $6; + } + | tUNUMBER ':' tUNUMBER ':' tUNUMBER tSNUMBER { + yyHour = $1; + yyMinutes = $3; + yySeconds = $5; + yyMeridian = MER24; + yyDSTmode = DSToff; + yyTimezone = - ($6 % 100 + ($6 / 100) * 60); + } + ; + +zone : tZONE tDST { + yyTimezone = $1; + yyDSTmode = DSTon; + } + | tZONE { + yyTimezone = $1; + yyDSTmode = DSToff; + } + | tDAYZONE { + yyTimezone = $1; + yyDSTmode = DSTon; + } + ; + +day : tDAY { + yyDayOrdinal = 1; + yyDayNumber = $1; + } + | tDAY ',' { + yyDayOrdinal = 1; + yyDayNumber = $1; + } + | tUNUMBER tDAY { + yyDayOrdinal = $1; + yyDayNumber = $2; + } + ; + +date : tUNUMBER '/' tUNUMBER { + yyMonth = $1; + yyDay = $3; + } + | tUNUMBER '/' tUNUMBER '/' tUNUMBER { + yyMonth = $1; + yyDay = $3; + yyYear = $5; + } + | tMONTH tUNUMBER { + yyMonth = $1; + yyDay = $2; + } + | tMONTH tUNUMBER ',' tUNUMBER { + yyMonth = $1; + yyDay = $2; + yyYear = $4; + } + | tUNUMBER tMONTH { + yyMonth = $2; + yyDay = $1; + } + | tEPOCH { + yyMonth = 1; + yyDay = 1; + yyYear = EPOCH; + } + | tUNUMBER tMONTH tUNUMBER { + yyMonth = $2; + yyDay = $1; + yyYear = $3; + } + ; + +rel : relunit tAGO { + yyRelSeconds = -yyRelSeconds; + yyRelMonth = -yyRelMonth; + } + | relunit + ; + +relunit : tUNUMBER tMINUTE_UNIT { + yyRelSeconds += $1 * $2 * 60L; + } + | tSNUMBER tMINUTE_UNIT { + yyRelSeconds += $1 * $2 * 60L; + } + | tMINUTE_UNIT { + yyRelSeconds += $1 * 60L; + } + | tSNUMBER tSEC_UNIT { + yyRelSeconds += $1; + } + | tUNUMBER tSEC_UNIT { + yyRelSeconds += $1; + } + | tSEC_UNIT { + yyRelSeconds++; + } + | tSNUMBER tMONTH_UNIT { + yyRelMonth += $1 * $2; + } + | tUNUMBER tMONTH_UNIT { + yyRelMonth += $1 * $2; + } + | tMONTH_UNIT { + yyRelMonth += $1; + } + ; + +number : tUNUMBER + { + if (yyHaveTime && yyHaveDate && !yyHaveRel) { + yyYear = $1; + } else { + yyHaveTime++; + if ($1 < 100) { + yyHour = 0; + yyMinutes = $1; + } else { + yyHour = $1 / 100; + yyMinutes = $1 % 100; + } + yySeconds = 0; + yyMeridian = MER24; + } + } +; + +o_merid : /* NULL */ { + $$ = MER24; + } + | tMERIDIAN { + $$ = $1; + } + ; + +%% + +/* + * Month and day table. + */ +static TABLE MonthDayTable[] = { + { "january", tMONTH, 1 }, + { "february", tMONTH, 2 }, + { "march", tMONTH, 3 }, + { "april", tMONTH, 4 }, + { "may", tMONTH, 5 }, + { "june", tMONTH, 6 }, + { "july", tMONTH, 7 }, + { "august", tMONTH, 8 }, + { "september", tMONTH, 9 }, + { "sept", tMONTH, 9 }, + { "october", tMONTH, 10 }, + { "november", tMONTH, 11 }, + { "december", tMONTH, 12 }, + { "sunday", tDAY, 0 }, + { "monday", tDAY, 1 }, + { "tuesday", tDAY, 2 }, + { "tues", tDAY, 2 }, + { "wednesday", tDAY, 3 }, + { "wednes", tDAY, 3 }, + { "thursday", tDAY, 4 }, + { "thur", tDAY, 4 }, + { "thurs", tDAY, 4 }, + { "friday", tDAY, 5 }, + { "saturday", tDAY, 6 }, + { NULL } +}; + +/* + * Time units table. + */ +static TABLE UnitsTable[] = { + { "year", tMONTH_UNIT, 12 }, + { "month", tMONTH_UNIT, 1 }, + { "fortnight", tMINUTE_UNIT, 14 * 24 * 60 }, + { "week", tMINUTE_UNIT, 7 * 24 * 60 }, + { "day", tMINUTE_UNIT, 1 * 24 * 60 }, + { "hour", tMINUTE_UNIT, 60 }, + { "minute", tMINUTE_UNIT, 1 }, + { "min", tMINUTE_UNIT, 1 }, + { "second", tSEC_UNIT, 1 }, + { "sec", tSEC_UNIT, 1 }, + { NULL } +}; + +/* + * Assorted relative-time words. + */ +static TABLE OtherTable[] = { + { "tomorrow", tMINUTE_UNIT, 1 * 24 * 60 }, + { "yesterday", tMINUTE_UNIT, -1 * 24 * 60 }, + { "today", tMINUTE_UNIT, 0 }, + { "now", tMINUTE_UNIT, 0 }, + { "last", tUNUMBER, -1 }, + { "this", tMINUTE_UNIT, 0 }, + { "next", tUNUMBER, 2 }, +#if 0 + { "first", tUNUMBER, 1 }, +/* { "second", tUNUMBER, 2 }, */ + { "third", tUNUMBER, 3 }, + { "fourth", tUNUMBER, 4 }, + { "fifth", tUNUMBER, 5 }, + { "sixth", tUNUMBER, 6 }, + { "seventh", tUNUMBER, 7 }, + { "eighth", tUNUMBER, 8 }, + { "ninth", tUNUMBER, 9 }, + { "tenth", tUNUMBER, 10 }, + { "eleventh", tUNUMBER, 11 }, + { "twelfth", tUNUMBER, 12 }, +#endif + { "ago", tAGO, 1 }, + { "epoch", tEPOCH, 0 }, + { NULL } +}; + +/* + * The timezone table. (Note: This table was modified to not use any floating + * point constants to work around an SGI compiler bug). + */ +static TABLE TimezoneTable[] = { + { "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */ + { "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */ + { "utc", tZONE, HOUR( 0) }, + { "wet", tZONE, HOUR( 0) } , /* Western European */ + { "bst", tDAYZONE, HOUR( 0) }, /* British Summer */ + { "wat", tZONE, HOUR( 1) }, /* West Africa */ + { "at", tZONE, HOUR( 2) }, /* Azores */ +#if 0 + /* For completeness. BST is also British Summer, and GST is + * also Guam Standard. */ + { "bst", tZONE, HOUR( 3) }, /* Brazil Standard */ + { "gst", tZONE, HOUR( 3) }, /* Greenland Standard */ +#endif + { "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */ + { "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */ + { "ndt", tDAYZONE, HOUR( 7/2) }, /* Newfoundland Daylight */ + { "ast", tZONE, HOUR( 4) }, /* Atlantic Standard */ + { "adt", tDAYZONE, HOUR( 4) }, /* Atlantic Daylight */ + { "est", tZONE, HOUR( 5) }, /* Eastern Standard */ + { "edt", tDAYZONE, HOUR( 5) }, /* Eastern Daylight */ + { "cst", tZONE, HOUR( 6) }, /* Central Standard */ + { "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */ + { "mst", tZONE, HOUR( 7) }, /* Mountain Standard */ + { "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */ + { "pst", tZONE, HOUR( 8) }, /* Pacific Standard */ + { "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */ + { "yst", tZONE, HOUR( 9) }, /* Yukon Standard */ + { "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */ + { "hst", tZONE, HOUR(10) }, /* Hawaii Standard */ + { "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */ + { "cat", tZONE, HOUR(10) }, /* Central Alaska */ + { "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */ + { "nt", tZONE, HOUR(11) }, /* Nome */ + { "idlw", tZONE, HOUR(12) }, /* International Date Line West */ + { "cet", tZONE, -HOUR( 1) }, /* Central European */ + { "met", tZONE, -HOUR( 1) }, /* Middle European */ + { "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */ + { "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */ + { "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */ + { "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */ + { "fwt", tZONE, -HOUR( 1) }, /* French Winter */ + { "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */ + { "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */ + { "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */ + { "it", tZONE, -HOUR( 7/2) }, /* Iran */ + { "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */ + { "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */ + { "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */ + { "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */ +#if 0 + /* For completeness. NST is also Newfoundland Stanard, nad SST is + * also Swedish Summer. */ + { "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */ + { "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */ +#endif /* 0 */ + { "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */ + { "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */ + { "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */ + { "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */ + { "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */ + { "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */ + { "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */ + { "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */ + { "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */ + { "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */ + { "nzt", tZONE, -HOUR(12) }, /* New Zealand */ + { "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */ + { "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */ + { "idle", tZONE, -HOUR(12) }, /* International Date Line East */ + /* ADDED BY Marco Nijdam */ + { "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */ + /* End ADDED */ + { NULL } +}; + +/* + * Military timezone table. + */ +static TABLE MilitaryTable[] = { + { "a", tZONE, HOUR( 1) }, + { "b", tZONE, HOUR( 2) }, + { "c", tZONE, HOUR( 3) }, + { "d", tZONE, HOUR( 4) }, + { "e", tZONE, HOUR( 5) }, + { "f", tZONE, HOUR( 6) }, + { "g", tZONE, HOUR( 7) }, + { "h", tZONE, HOUR( 8) }, + { "i", tZONE, HOUR( 9) }, + { "k", tZONE, HOUR( 10) }, + { "l", tZONE, HOUR( 11) }, + { "m", tZONE, HOUR( 12) }, + { "n", tZONE, HOUR(- 1) }, + { "o", tZONE, HOUR(- 2) }, + { "p", tZONE, HOUR(- 3) }, + { "q", tZONE, HOUR(- 4) }, + { "r", tZONE, HOUR(- 5) }, + { "s", tZONE, HOUR(- 6) }, + { "t", tZONE, HOUR(- 7) }, + { "u", tZONE, HOUR(- 8) }, + { "v", tZONE, HOUR(- 9) }, + { "w", tZONE, HOUR(-10) }, + { "x", tZONE, HOUR(-11) }, + { "y", tZONE, HOUR(-12) }, + { "z", tZONE, HOUR( 0) }, + { NULL } +}; + + +/* + * Dump error messages in the bit bucket. + */ +static void +yyerror(s) + char *s; +{ +} + + +static time_t +ToSeconds(Hours, Minutes, Seconds, Meridian) + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; +{ + if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) + return -1; + switch (Meridian) { + case MER24: + if (Hours < 0 || Hours > 23) + return -1; + return (Hours * 60L + Minutes) * 60L + Seconds; + case MERam: + if (Hours < 1 || Hours > 12) + return -1; + return ((Hours % 12) * 60L + Minutes) * 60L + Seconds; + case MERpm: + if (Hours < 1 || Hours > 12) + return -1; + return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds; + } + return -1; /* Should never be reached */ +} + + +static int +Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr) + time_t Month; + time_t Day; + time_t Year; + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; + DSTMODE DSTmode; + time_t *TimePtr; +{ + static int DaysInMonth[12] = { + 31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 + }; + time_t tod; + time_t Julian; + int i; + + DaysInMonth[1] = Year % 4 == 0 && (Year % 100 != 0 || Year % 400 == 0) + ? 29 : 28; + if (Month < 1 || Month > 12 + || Year < START_OF_TIME || Year > END_OF_TIME + || Day < 1 || Day > DaysInMonth[(int)--Month]) + return -1; + + for (Julian = Day - 1, i = 0; i < Month; i++) + Julian += DaysInMonth[i]; + if (Year >= EPOCH) { + for (i = EPOCH; i < Year; i++) + Julian += 365 + (i % 4 == 0); + } else { + for (i = Year; i < EPOCH; i++) + Julian -= 365 + (i % 4 == 0); + } + Julian *= SECSPERDAY; + Julian += yyTimezone * 60L; + if ((tod = ToSeconds(Hours, Minutes, Seconds, Meridian)) < 0) + return -1; + Julian += tod; + if (DSTmode == DSTon + || (DSTmode == DSTmaybe && TclpGetDate(&Julian, 0)->tm_isdst)) + Julian -= 60 * 60; + *TimePtr = Julian; + return 0; +} + + +static time_t +DSTcorrect(Start, Future) + time_t Start; + time_t Future; +{ + time_t StartDay; + time_t FutureDay; + + StartDay = (TclpGetDate(&Start, 0)->tm_hour + 1) % 24; + FutureDay = (TclpGetDate(&Future, 0)->tm_hour + 1) % 24; + return (Future - Start) + (StartDay - FutureDay) * 60L * 60L; +} + + +static time_t +RelativeDate(Start, DayOrdinal, DayNumber) + time_t Start; + time_t DayOrdinal; + time_t DayNumber; +{ + struct tm *tm; + time_t now; + + now = Start; + tm = TclpGetDate(&now, 0); + now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7); + now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1); + return DSTcorrect(Start, now); +} + + +static int +RelativeMonth(Start, RelMonth, TimePtr) + time_t Start; + time_t RelMonth; + time_t *TimePtr; +{ + struct tm *tm; + time_t Month; + time_t Year; + time_t Julian; + int result; + + if (RelMonth == 0) { + *TimePtr = 0; + return 0; + } + tm = TclpGetDate(&Start, 0); + Month = 12 * (tm->tm_year + TM_YEAR_BASE) + tm->tm_mon + RelMonth; + Year = Month / 12; + Month = Month % 12 + 1; + result = Convert(Month, (time_t) tm->tm_mday, Year, + (time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec, + MER24, DSTmaybe, &Julian); + /* + * The following iteration takes into account the case were we jump + * into a "short month". Far example, "one month from Jan 31" will + * fail because there is no Feb 31. The code below will reduce the + * day and try converting the date until we succed or the date equals + * 28 (which always works unless the date is bad in another way). + */ + + while ((result != 0) && (tm->tm_mday > 28)) { + tm->tm_mday--; + result = Convert(Month, (time_t) tm->tm_mday, Year, + (time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec, + MER24, DSTmaybe, &Julian); + } + if (result != 0) { + return -1; + } + *TimePtr = DSTcorrect(Start, Julian); + return 0; +} + + +static int +LookupWord(buff) + char *buff; +{ + register char *p; + register char *q; + register TABLE *tp; + int i; + int abbrev; + + /* + * Make it lowercase. + */ + for (p = buff; *p; p++) { + if (isupper(UCHAR(*p))) { + *p = (char) tolower(UCHAR(*p)); + } + } + + if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) { + yylval.Meridian = MERam; + return tMERIDIAN; + } + if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) { + yylval.Meridian = MERpm; + return tMERIDIAN; + } + + /* + * See if we have an abbreviation for a month. + */ + if (strlen(buff) == 3) { + abbrev = 1; + } else if (strlen(buff) == 4 && buff[3] == '.') { + abbrev = 1; + buff[3] = '\0'; + } else { + abbrev = 0; + } + + for (tp = MonthDayTable; tp->name; tp++) { + if (abbrev) { + if (strncmp(buff, tp->name, 3) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } else if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + /* + * Strip off any plural and try the units table again. + */ + i = strlen(buff) - 1; + if (buff[i] == 's') { + buff[i] = '\0'; + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + } + + for (tp = OtherTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + /* + * Military timezones. + */ + if (buff[1] == '\0' && isalpha(UCHAR(*buff))) { + for (tp = MilitaryTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + } + + /* + * Drop out any periods and try the timezone table again. + */ + for (i = 0, p = q = buff; *q; q++) + if (*q != '.') { + *p++ = *q; + } else { + i++; + } + *p = '\0'; + if (i) { + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + } + + return tID; +} + + +static int +yylex() +{ + register char c; + register char *p; + char buff[20]; + int Count; + int sign; + + for ( ; ; ) { + while (isspace((unsigned char) (*yyInput))) { + yyInput++; + } + + if (isdigit(c = *yyInput) || c == '-' || c == '+') { + if (c == '-' || c == '+') { + sign = c == '-' ? -1 : 1; + if (!isdigit(*++yyInput)) { + /* + * skip the '-' sign + */ + continue; + } + } else { + sign = 0; + } + for (yylval.Number = 0; isdigit(c = *yyInput++); ) { + yylval.Number = 10 * yylval.Number + c - '0'; + } + yyInput--; + if (sign < 0) { + yylval.Number = -yylval.Number; + } + return sign ? tSNUMBER : tUNUMBER; + } + if (isalpha(UCHAR(c))) { + for (p = buff; isalpha(c = *yyInput++) || c == '.'; ) { + if (p < &buff[sizeof buff - 1]) { + *p++ = c; + } + } + *p = '\0'; + yyInput--; + return LookupWord(buff); + } + if (c != '(') { + return *yyInput++; + } + Count = 0; + do { + c = *yyInput++; + if (c == '\0') { + return c; + } else if (c == '(') { + Count++; + } else if (c == ')') { + Count--; + } + } while (Count > 0); + } +} + +/* + * Specify zone is of -50000 to force GMT. (This allows BST to work). + */ + +int +TclGetDate(p, now, zone, timePtr) + char *p; + unsigned long now; + long zone; + unsigned long *timePtr; +{ + struct tm *tm; + time_t Start; + time_t Time; + time_t tod; + int thisyear; + + yyInput = p; + tm = TclpGetDate((time_t *) &now, 0); + thisyear = tm->tm_year + TM_YEAR_BASE; + yyYear = thisyear; + yyMonth = tm->tm_mon + 1; + yyDay = tm->tm_mday; + yyTimezone = zone; + if (zone == -50000) { + yyDSTmode = DSToff; /* assume GMT */ + yyTimezone = 0; + } else { + yyDSTmode = DSTmaybe; + } + yyHour = 0; + yyMinutes = 0; + yySeconds = 0; + yyMeridian = MER24; + yyRelSeconds = 0; + yyRelMonth = 0; + yyHaveDate = 0; + yyHaveDay = 0; + yyHaveRel = 0; + yyHaveTime = 0; + yyHaveZone = 0; + + if (yyparse() || yyHaveTime > 1 || yyHaveZone > 1 || yyHaveDate > 1 || + yyHaveDay > 1) { + return -1; + } + + if (yyHaveDate || yyHaveTime || yyHaveDay) { + if (TclDateYear < 0) { + TclDateYear = -TclDateYear; + } + /* + * The following line handles years that are specified using + * only two digits. The line of code below implements a policy + * defined by the X/Open workgroup on the millinium rollover. + * Note: some of those dates may not actually be valid on some + * platforms. The POSIX standard startes that the dates 70-99 + * shall refer to 1970-1999 and 00-38 shall refer to 2000-2038. + * This later definition should work on all platforms. + */ + + if (TclDateYear < 100) { + if (TclDateYear >= 69) { + TclDateYear += 1900; + } else { + TclDateYear += 2000; + } + } + if (Convert(yyMonth, yyDay, yyYear, yyHour, yyMinutes, yySeconds, + yyMeridian, yyDSTmode, &Start) < 0) { + return -1; + } + } else { + Start = now; + if (!yyHaveRel) { + Start -= ((tm->tm_hour * 60L) + tm->tm_min * 60L) + tm->tm_sec; + } + } + + Start += yyRelSeconds; + if (RelativeMonth(Start, yyRelMonth, &Time) < 0) { + return -1; + } + Start += Time; + + if (yyHaveDay && !yyHaveDate) { + tod = RelativeDate(Start, yyDayOrdinal, yyDayNumber); + Start += tod; + } + + *timePtr = Start; + return 0; +} diff --git a/tcl/generic/tclHash.c b/tcl/generic/tclHash.c new file mode 100644 index 00000000000..b38a2b1ce52 --- /dev/null +++ b/tcl/generic/tclHash.c @@ -0,0 +1,921 @@ +/* + * tclHash.c -- + * + * Implementation of in-memory hash tables for Tcl and Tcl-based + * applications. + * + * Copyright (c) 1991-1993 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * When there are this many entries per bucket, on average, rebuild + * the hash table to make it larger. + */ + +#define REBUILD_MULTIPLIER 3 + + +/* + * The following macro takes a preliminary integer hash value and + * produces an index into a hash tables bucket list. The idea is + * to make it so that preliminary values that are arbitrarily similar + * will end up in different buckets. The hash function was taken + * from a random-number generator. + */ + +#define RANDOM_INDEX(tablePtr, i) \ + (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) + +/* + * Procedure prototypes for static procedures in this file: + */ + +static Tcl_HashEntry * ArrayFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key)); +static Tcl_HashEntry * ArrayCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key, int *newPtr)); +static Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key)); +static Tcl_HashEntry * BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key, int *newPtr)); +static unsigned int HashString _ANSI_ARGS_((CONST char *string)); +static void RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr)); +static Tcl_HashEntry * StringFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key)); +static Tcl_HashEntry * StringCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key, int *newPtr)); +static Tcl_HashEntry * OneWordFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key)); +static Tcl_HashEntry * OneWordCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key, int *newPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitHashTable -- + * + * Given storage for a hash table, set up the fields to prepare + * the hash table for use. + * + * Results: + * None. + * + * Side effects: + * TablePtr is now ready to be passed to Tcl_FindHashEntry and + * Tcl_CreateHashEntry. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_InitHashTable(tablePtr, keyType) + register Tcl_HashTable *tablePtr; /* Pointer to table record, which + * is supplied by the caller. */ + int keyType; /* Type of keys to use in table: + * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, + * or an integer >= 2. */ +{ + tablePtr->buckets = tablePtr->staticBuckets; + tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; + tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; + tablePtr->numBuckets = TCL_SMALL_HASH_TABLE; + tablePtr->numEntries = 0; + tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER; + tablePtr->downShift = 28; + tablePtr->mask = 3; + tablePtr->keyType = keyType; + if (keyType == TCL_STRING_KEYS) { + tablePtr->findProc = StringFind; + tablePtr->createProc = StringCreate; + } else if (keyType == TCL_ONE_WORD_KEYS) { + tablePtr->findProc = OneWordFind; + tablePtr->createProc = OneWordCreate; + } else { + tablePtr->findProc = ArrayFind; + tablePtr->createProc = ArrayCreate; + }; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteHashEntry -- + * + * Remove a single entry from a hash table. + * + * Results: + * None. + * + * Side effects: + * The entry given by entryPtr is deleted from its table and + * should never again be used by the caller. It is up to the + * caller to free the clientData field of the entry, if that + * is relevant. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteHashEntry(entryPtr) + Tcl_HashEntry *entryPtr; +{ + register Tcl_HashEntry *prevPtr; + + if (*entryPtr->bucketPtr == entryPtr) { + *entryPtr->bucketPtr = entryPtr->nextPtr; + } else { + for (prevPtr = *entryPtr->bucketPtr; ; prevPtr = prevPtr->nextPtr) { + if (prevPtr == NULL) { + panic("malformed bucket chain in Tcl_DeleteHashEntry"); + } + if (prevPtr->nextPtr == entryPtr) { + prevPtr->nextPtr = entryPtr->nextPtr; + break; + } + } + } + entryPtr->tablePtr->numEntries--; + ckfree((char *) entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteHashTable -- + * + * Free up everything associated with a hash table except for + * the record for the table itself. + * + * Results: + * None. + * + * Side effects: + * The hash table is no longer useable. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteHashTable(tablePtr) + register Tcl_HashTable *tablePtr; /* Table to delete. */ +{ + register Tcl_HashEntry *hPtr, *nextPtr; + int i; + + /* + * Free up all the entries in the table. + */ + + for (i = 0; i < tablePtr->numBuckets; i++) { + hPtr = tablePtr->buckets[i]; + while (hPtr != NULL) { + nextPtr = hPtr->nextPtr; + ckfree((char *) hPtr); + hPtr = nextPtr; + } + } + + /* + * Free up the bucket array, if it was dynamically allocated. + */ + + if (tablePtr->buckets != tablePtr->staticBuckets) { + ckfree((char *) tablePtr->buckets); + } + + /* + * Arrange for panics if the table is used again without + * re-initialization. + */ + + tablePtr->findProc = BogusFind; + tablePtr->createProc = BogusCreate; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FirstHashEntry -- + * + * Locate the first entry in a hash table and set up a record + * that can be used to step through all the remaining entries + * of the table. + * + * Results: + * The return value is a pointer to the first entry in tablePtr, + * or NULL if tablePtr has no entries in it. The memory at + * *searchPtr is initialized so that subsequent calls to + * Tcl_NextHashEntry will return all of the entries in the table, + * one at a time. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashEntry * +Tcl_FirstHashEntry(tablePtr, searchPtr) + Tcl_HashTable *tablePtr; /* Table to search. */ + Tcl_HashSearch *searchPtr; /* Place to store information about + * progress through the table. */ +{ + searchPtr->tablePtr = tablePtr; + searchPtr->nextIndex = 0; + searchPtr->nextEntryPtr = NULL; + return Tcl_NextHashEntry(searchPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NextHashEntry -- + * + * Once a hash table enumeration has been initiated by calling + * Tcl_FirstHashEntry, this procedure may be called to return + * successive elements of the table. + * + * Results: + * The return value is the next entry in the hash table being + * enumerated, or NULL if the end of the table is reached. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashEntry * +Tcl_NextHashEntry(searchPtr) + register Tcl_HashSearch *searchPtr; /* Place to store information about + * progress through the table. Must + * have been initialized by calling + * Tcl_FirstHashEntry. */ +{ + Tcl_HashEntry *hPtr; + + while (searchPtr->nextEntryPtr == NULL) { + if (searchPtr->nextIndex >= searchPtr->tablePtr->numBuckets) { + return NULL; + } + searchPtr->nextEntryPtr = + searchPtr->tablePtr->buckets[searchPtr->nextIndex]; + searchPtr->nextIndex++; + } + hPtr = searchPtr->nextEntryPtr; + searchPtr->nextEntryPtr = hPtr->nextPtr; + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_HashStats -- + * + * Return statistics describing the layout of the hash table + * in its hash buckets. + * + * Results: + * The return value is a malloc-ed string containing information + * about tablePtr. It is the caller's responsibility to free + * this string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_HashStats(tablePtr) + Tcl_HashTable *tablePtr; /* Table for which to produce stats. */ +{ +#define NUM_COUNTERS 10 + int count[NUM_COUNTERS], overflow, i, j; + double average, tmp; + register Tcl_HashEntry *hPtr; + char *result, *p; + + /* + * Compute a histogram of bucket usage. + */ + + for (i = 0; i < NUM_COUNTERS; i++) { + count[i] = 0; + } + overflow = 0; + average = 0.0; + for (i = 0; i < tablePtr->numBuckets; i++) { + j = 0; + for (hPtr = tablePtr->buckets[i]; hPtr != NULL; hPtr = hPtr->nextPtr) { + j++; + } + if (j < NUM_COUNTERS) { + count[j]++; + } else { + overflow++; + } + tmp = j; + average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0; + } + + /* + * Print out the histogram and a few other pieces of information. + */ + + result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300)); + sprintf(result, "%d entries in table, %d buckets\n", + tablePtr->numEntries, tablePtr->numBuckets); + p = result + strlen(result); + for (i = 0; i < NUM_COUNTERS; i++) { + sprintf(p, "number of buckets with %d entries: %d\n", + i, count[i]); + p += strlen(p); + } + sprintf(p, "number of buckets with %d or more entries: %d\n", + NUM_COUNTERS, overflow); + p += strlen(p); + sprintf(p, "average search distance for entry: %.1f", average); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * HashString -- + * + * Compute a one-word summary of a text string, which can be + * used to generate a hash index. + * + * Results: + * The return value is a one-word summary of the information in + * string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static unsigned int +HashString(string) + register CONST char *string;/* String from which to compute hash value. */ +{ + register unsigned int result; + register int c; + + /* + * I tried a zillion different hash functions and asked many other + * people for advice. Many people had their own favorite functions, + * all different, but no-one had much idea why they were good ones. + * I chose the one below (multiply by 9 and add new character) + * because of the following reasons: + * + * 1. Multiplying by 10 is perfect for keys that are decimal strings, + * and multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the + * hash value for ever, plus they spread fairly rapidly up to + * the high-order bits to fill out the hash value. This seems + * works well both for decimal and non-decimal strings. + */ + + result = 0; + while (1) { + c = *string; + string++; + if (c == 0) { + break; + } + result += (result<<3) + c; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * StringFind -- + * + * Given a hash table with string keys, and a string key, find + * the entry with a matching key. + * + * Results: + * The return value is a token for the matching entry in the + * hash table, or NULL if there was no matching entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +StringFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + CONST char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + register CONST char *p1, *p2; + int index; + + index = HashString(key) & tablePtr->mask; + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) { + if (*p1 != *p2) { + break; + } + if (*p1 == '\0') { + return hPtr; + } + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * StringCreate -- + * + * Given a hash table with string keys, and a string key, find + * the entry with a matching key. If there is no matching entry, + * then create a new entry that does match. + * + * Results: + * The return value is a pointer to the matching entry. If this + * is a newly-created entry, then *newPtr will be set to a non-zero + * value; otherwise *newPtr will be set to 0. If this is a new + * entry the value stored in the entry will initially be 0. + * + * Side effects: + * A new entry may be added to the hash table. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +StringCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + CONST char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + register Tcl_HashEntry *hPtr; + register CONST char *p1, *p2; + int index; + + index = HashString(key) & tablePtr->mask; + + /* + * Search all of the entries in this bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) { + if (*p1 != *p2) { + break; + } + if (*p1 == '\0') { + *newPtr = 0; + return hPtr; + } + } + } + + /* + * Entry not found. Add a new one to the bucket. + */ + + *newPtr = 1; + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) + (sizeof(Tcl_HashEntry) + strlen(key) - (sizeof(hPtr->key) -1))); + hPtr->tablePtr = tablePtr; + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + hPtr->clientData = 0; + strcpy(hPtr->key.string, key); + *hPtr->bucketPtr = hPtr; + tablePtr->numEntries++; + + /* + * If the table has exceeded a decent size, rebuild it with many + * more buckets. + */ + + if (tablePtr->numEntries >= tablePtr->rebuildSize) { + RebuildTable(tablePtr); + } + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * OneWordFind -- + * + * Given a hash table with one-word keys, and a one-word key, find + * the entry with a matching key. + * + * Results: + * The return value is a token for the matching entry in the + * hash table, or NULL if there was no matching entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +OneWordFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register CONST char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + int index; + + index = RANDOM_INDEX(tablePtr, key); + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + if (hPtr->key.oneWordValue == key) { + return hPtr; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * OneWordCreate -- + * + * Given a hash table with one-word keys, and a one-word key, find + * the entry with a matching key. If there is no matching entry, + * then create a new entry that does match. + * + * Results: + * The return value is a pointer to the matching entry. If this + * is a newly-created entry, then *newPtr will be set to a non-zero + * value; otherwise *newPtr will be set to 0. If this is a new + * entry the value stored in the entry will initially be 0. + * + * Side effects: + * A new entry may be added to the hash table. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +OneWordCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register CONST char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + register Tcl_HashEntry *hPtr; + int index; + + index = RANDOM_INDEX(tablePtr, key); + + /* + * Search all of the entries in this bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + if (hPtr->key.oneWordValue == key) { + *newPtr = 0; + return hPtr; + } + } + + /* + * Entry not found. Add a new one to the bucket. + */ + + *newPtr = 1; + hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry)); + hPtr->tablePtr = tablePtr; + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + hPtr->clientData = 0; + hPtr->key.oneWordValue = (char *) key; /* CONST XXXX */ + *hPtr->bucketPtr = hPtr; + tablePtr->numEntries++; + + /* + * If the table has exceeded a decent size, rebuild it with many + * more buckets. + */ + + if (tablePtr->numEntries >= tablePtr->rebuildSize) { + RebuildTable(tablePtr); + } + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayFind -- + * + * Given a hash table with array-of-int keys, and a key, find + * the entry with a matching key. + * + * Results: + * The return value is a token for the matching entry in the + * hash table, or NULL if there was no matching entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +ArrayFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + CONST char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + int *arrayPtr = (int *) key; + register int *iPtr1, *iPtr2; + int index, count; + + for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr; + count > 0; count--, iPtr1++) { + index += *iPtr1; + } + index = RANDOM_INDEX(tablePtr, index); + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, + count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { + if (count == 0) { + return hPtr; + } + if (*iPtr1 != *iPtr2) { + break; + } + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayCreate -- + * + * Given a hash table with one-word keys, and a one-word key, find + * the entry with a matching key. If there is no matching entry, + * then create a new entry that does match. + * + * Results: + * The return value is a pointer to the matching entry. If this + * is a newly-created entry, then *newPtr will be set to a non-zero + * value; otherwise *newPtr will be set to 0. If this is a new + * entry the value stored in the entry will initially be 0. + * + * Side effects: + * A new entry may be added to the hash table. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +ArrayCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register CONST char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + register Tcl_HashEntry *hPtr; + int *arrayPtr = (int *) key; + register int *iPtr1, *iPtr2; + int index, count; + + for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr; + count > 0; count--, iPtr1++) { + index += *iPtr1; + } + index = RANDOM_INDEX(tablePtr, index); + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, + count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { + if (count == 0) { + *newPtr = 0; + return hPtr; + } + if (*iPtr1 != *iPtr2) { + break; + } + } + } + + /* + * Entry not found. Add a new one to the bucket. + */ + + *newPtr = 1; + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry) + + (tablePtr->keyType*sizeof(int)) - 4)); + hPtr->tablePtr = tablePtr; + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + hPtr->clientData = 0; + for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, count = tablePtr->keyType; + count > 0; count--, iPtr1++, iPtr2++) { + *iPtr2 = *iPtr1; + } + *hPtr->bucketPtr = hPtr; + tablePtr->numEntries++; + + /* + * If the table has exceeded a decent size, rebuild it with many + * more buckets. + */ + + if (tablePtr->numEntries >= tablePtr->rebuildSize) { + RebuildTable(tablePtr); + } + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * BogusFind -- + * + * This procedure is invoked when an Tcl_FindHashEntry is called + * on a table that has been deleted. + * + * Results: + * If panic returns (which it shouldn't) this procedure returns + * NULL. + * + * Side effects: + * Generates a panic. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tcl_HashEntry * +BogusFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + CONST char *key; /* Key to use to find matching entry. */ +{ + panic("called Tcl_FindHashEntry on deleted table"); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * BogusCreate -- + * + * This procedure is invoked when an Tcl_CreateHashEntry is called + * on a table that has been deleted. + * + * Results: + * If panic returns (which it shouldn't) this procedure returns + * NULL. + * + * Side effects: + * Generates a panic. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tcl_HashEntry * +BogusCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + CONST char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + panic("called Tcl_CreateHashEntry on deleted table"); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * RebuildTable -- + * + * This procedure is invoked when the ratio of entries to hash + * buckets becomes too large. It creates a new table with a + * larger bucket array and moves all of the entries into the + * new table. + * + * Results: + * None. + * + * Side effects: + * Memory gets reallocated and entries get re-hashed to new + * buckets. + * + *---------------------------------------------------------------------- + */ + +static void +RebuildTable(tablePtr) + register Tcl_HashTable *tablePtr; /* Table to enlarge. */ +{ + int oldSize, count, index; + Tcl_HashEntry **oldBuckets; + register Tcl_HashEntry **oldChainPtr, **newChainPtr; + register Tcl_HashEntry *hPtr; + + oldSize = tablePtr->numBuckets; + oldBuckets = tablePtr->buckets; + + /* + * Allocate and initialize the new bucket array, and set up + * hashing constants for new array size. + */ + + tablePtr->numBuckets *= 4; + tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned) + (tablePtr->numBuckets * sizeof(Tcl_HashEntry *))); + for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; + count > 0; count--, newChainPtr++) { + *newChainPtr = NULL; + } + tablePtr->rebuildSize *= 4; + tablePtr->downShift -= 2; + tablePtr->mask = (tablePtr->mask << 2) + 3; + + /* + * Rehash all of the existing entries into the new bucket array. + */ + + for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) { + for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { + *oldChainPtr = hPtr->nextPtr; + if (tablePtr->keyType == TCL_STRING_KEYS) { + index = HashString(hPtr->key.string) & tablePtr->mask; + } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { + index = RANDOM_INDEX(tablePtr, hPtr->key.oneWordValue); + } else { + register int *iPtr; + int count; + + for (index = 0, count = tablePtr->keyType, + iPtr = hPtr->key.words; count > 0; count--, iPtr++) { + index += *iPtr; + } + index = RANDOM_INDEX(tablePtr, index); + } + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; + } + } + + /* + * Free up the old bucket array, if it was dynamically allocated. + */ + + if (oldBuckets != tablePtr->staticBuckets) { + ckfree((char *) oldBuckets); + } +} diff --git a/tcl/generic/tclHistory.c b/tcl/generic/tclHistory.c new file mode 100644 index 00000000000..99f9ebeb243 --- /dev/null +++ b/tcl/generic/tclHistory.c @@ -0,0 +1,155 @@ +/* + * tclHistory.c -- + * + * This module and the Tcl library file history.tcl together implement + * Tcl command history. Tcl_RecordAndEval(Obj) can be called to record + * commands ("events") before they are executed. Commands defined in + * history.tcl may be used to perform history substitutions. + * + * Copyright (c) 1990-1993 The Regents of the University of California. + * Copyright (c) 1994-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + + +/* + *---------------------------------------------------------------------- + * + * Tcl_RecordAndEval -- + * + * This procedure adds its command argument to the current list of + * recorded events and then executes the command by calling + * Tcl_Eval. + * + * Results: + * The return value is a standard Tcl return value, the result of + * executing cmd. + * + * Side effects: + * The command is recorded and executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RecordAndEval(interp, cmd, flags) + Tcl_Interp *interp; /* Token for interpreter in which command + * will be executed. */ + char *cmd; /* Command to record. */ + int flags; /* Additional flags. TCL_NO_EVAL means + * only record: don't execute command. + * TCL_EVAL_GLOBAL means use Tcl_GlobalEval + * instead of Tcl_Eval. */ +{ + register Tcl_Obj *cmdPtr; + int length = strlen(cmd); + int result; + + if (length > 0) { + /* + * Call Tcl_RecordAndEvalObj to do the actual work. + */ + + TclNewObj(cmdPtr); + TclInitStringRep(cmdPtr, cmd, length); + Tcl_IncrRefCount(cmdPtr); + + result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); + + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + + /* + * Discard the Tcl object created to hold the command. + */ + + Tcl_DecrRefCount(cmdPtr); + } else { + /* + * An empty string. Just reset the interpreter's result. + */ + + Tcl_ResetResult(interp); + result = TCL_OK; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RecordAndEvalObj -- + * + * This procedure adds the command held in its argument object to the + * current list of recorded events and then executes the command by + * calling Tcl_EvalObj. + * + * Results: + * The return value is a standard Tcl return value, the result of + * executing the command. + * + * Side effects: + * The command is recorded and executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RecordAndEvalObj(interp, cmdPtr, flags) + Tcl_Interp *interp; /* Token for interpreter in which command + * will be executed. */ + Tcl_Obj *cmdPtr; /* Points to object holding the command to + * record and execute. */ + int flags; /* Additional flags. TCL_NO_EVAL means + * record only: don't execute the command. + * TCL_EVAL_GLOBAL means use + * Tcl_GlobalEvalObj instead of + * Tcl_EvalObj. */ +{ + Interp *iPtr = (Interp *) interp; + int result; + Tcl_Obj *list[3]; + register Tcl_Obj *objPtr; + + /* + * Do recording by eval'ing a tcl history command: history add $cmd. + */ + + list[0] = Tcl_NewStringObj("history", -1); + list[1] = Tcl_NewStringObj("add", -1); + list[2] = cmdPtr; + + objPtr = Tcl_NewListObj(3, list); + Tcl_IncrRefCount(objPtr); + (void) Tcl_GlobalEvalObj(interp, objPtr); + Tcl_DecrRefCount(objPtr); + + /* + * Execute the command. + */ + + result = TCL_OK; + if (!(flags & TCL_NO_EVAL)) { + iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL); + if (flags & TCL_EVAL_GLOBAL) { + result = Tcl_GlobalEvalObj(interp, cmdPtr); + } else { + result = Tcl_EvalObj(interp, cmdPtr); + } + } + return result; +} diff --git a/tcl/generic/tclIO.c b/tcl/generic/tclIO.c new file mode 100644 index 00000000000..f3e080e7189 --- /dev/null +++ b/tcl/generic/tclIO.c @@ -0,0 +1,6053 @@ +/* + * tclIO.c -- + * + * This file provides the generic portions (those that are the same on + * all platforms and for all channel types) of Tcl's IO facilities. + * + * Copyright (c) 1998 Scriptics Corporation + * Copyright (c) 1995-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not + * compile on systems where neither is defined. We want both defined so + * that we can test safely for both. In the code we still have to test for + * both because there may be systems on which both are defined and have + * different values. + */ + +#if ((!defined(EWOULDBLOCK)) && (defined(EAGAIN))) +# define EWOULDBLOCK EAGAIN +#endif +#if ((!defined(EAGAIN)) && (defined(EWOULDBLOCK))) +# define EAGAIN EWOULDBLOCK +#endif +#if ((!defined(EAGAIN)) && (!defined(EWOULDBLOCK))) + error one of EWOULDBLOCK or EAGAIN must be defined +#endif + +/* + * The following structure encapsulates the state for a background channel + * copy. Note that the data buffer for the copy will be appended to this + * structure. + */ + +typedef struct CopyState { + struct Channel *readPtr; /* Pointer to input channel. */ + struct Channel *writePtr; /* Pointer to output channel. */ + int readFlags; /* Original read channel flags. */ + int writeFlags; /* Original write channel flags. */ + int toRead; /* Number of bytes to copy, or -1. */ + int total; /* Total bytes transferred (written). */ + Tcl_Interp *interp; /* Interp that started the copy. */ + Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */ + int bufSize; /* Size of appended buffer. */ + char buffer[1]; /* Copy buffer, this must be the last + * field. */ +} CopyState; + +/* + * struct ChannelBuffer: + * + * Buffers data being sent to or from a channel. + */ + +typedef struct ChannelBuffer { + int nextAdded; /* The next position into which a character + * will be put in the buffer. */ + int nextRemoved; /* Position of next byte to be removed + * from the buffer. */ + int bufSize; /* How big is the buffer? */ + struct ChannelBuffer *nextPtr; + /* Next buffer in chain. */ + char buf[4]; /* Placeholder for real buffer. The real + * buffer occuppies this space + bufSize-4 + * bytes. This must be the last field in + * the structure. */ +} ChannelBuffer; + +#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) + +/* + * The following defines the *default* buffer size for channels. + */ + +#define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4) + +/* + * Structure to record a close callback. One such record exists for + * each close callback registered for a channel. + */ + +typedef struct CloseCallback { + Tcl_CloseProc *proc; /* The procedure to call. */ + ClientData clientData; /* Arbitrary one-word data to pass + * to the callback. */ + struct CloseCallback *nextPtr; /* For chaining close callbacks. */ +} CloseCallback; + +/* + * The following structure describes the information saved from a call to + * "fileevent". This is used later when the event being waited for to + * invoke the saved script in the interpreter designed in this record. + */ + +typedef struct EventScriptRecord { + struct Channel *chanPtr; /* The channel for which this script is + * registered. This is used only when an + * error occurs during evaluation of the + * script, to delete the handler. */ + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* In what interpreter to invoke script? */ + int mask; /* Events must overlap current mask for the + * stored script to be invoked. */ + struct EventScriptRecord *nextPtr; + /* Next in chain of records. */ +} EventScriptRecord; + +/* + * struct Channel: + * + * One of these structures is allocated for each open channel. It contains data + * specific to the channel but which belongs to the generic part of the Tcl + * channel mechanism, and it points at an instance specific (and type + * specific) * instance data, and at a channel type structure. + */ + +typedef struct Channel { + char *channelName; /* The name of the channel instance in Tcl + * commands. Storage is owned by the generic IO + * code, is dynamically allocated. */ + int flags; /* ORed combination of the flags defined + * below. */ + Tcl_EolTranslation inputTranslation; + /* What translation to apply for end of line + * sequences on input? */ + Tcl_EolTranslation outputTranslation; + /* What translation to use for generating + * end of line sequences in output? */ + int inEofChar; /* If nonzero, use this as a signal of EOF + * on input. */ + int outEofChar; /* If nonzero, append this to the channel + * when it is closed if it is open for + * writing. */ + int unreportedError; /* Non-zero if an error report was deferred + * because it happened in the background. The + * value is the POSIX error code. */ + ClientData instanceData; /* Instance specific data. */ + Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ + int refCount; /* How many interpreters hold references to + * this IO channel? */ + CloseCallback *closeCbPtr; /* Callbacks registered to be called when the + * channel is closed. */ + ChannelBuffer *curOutPtr; /* Current output buffer being filled. */ + ChannelBuffer *outQueueHead;/* Points at first buffer in output queue. */ + ChannelBuffer *outQueueTail;/* Points at last buffer in output queue. */ + + ChannelBuffer *saveInBufPtr;/* Buffer saved for input queue - eliminates + * need to allocate a new buffer for "gets" + * that crosses buffer boundaries. */ + ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ + ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ + + struct ChannelHandler *chPtr;/* List of channel handlers registered + * for this channel. */ + int interestMask; /* Mask of all events this channel has + * handlers for. */ + struct Channel *nextChanPtr;/* Next in list of channels currently open. */ + EventScriptRecord *scriptRecordPtr; + /* Chain of all scripts registered for + * event handlers ("fileevent") on this + * channel. */ + int bufSize; /* What size buffers to allocate? */ + Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */ + CopyState *csPtr; /* State of background copy, or NULL. */ +} Channel; + +/* + * Values for the flags field in Channel. Any ORed combination of the + * following flags can be stored in the field. These flags record various + * options and state bits about the channel. In addition to the flags below, + * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set. + */ + +#define CHANNEL_NONBLOCKING (1<<3) /* Channel is currently in + * nonblocking mode. */ +#define CHANNEL_LINEBUFFERED (1<<4) /* Output to the channel must be + * flushed after every newline. */ +#define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always + * be flushed immediately. */ +#define BUFFER_READY (1<<6) /* Current output buffer (the + * curOutPtr field in the + * channel structure) should be + * output as soon as possible even + * though it may not be full. */ +#define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the + * queued output buffers has been + * scheduled. */ +#define CHANNEL_CLOSED (1<<8) /* Channel has been closed. No + * further Tcl-level IO on the + * channel is allowed. */ +#define CHANNEL_EOF (1<<9) /* EOF occurred on this channel. + * This bit is cleared before every + * input operation. */ +#define CHANNEL_STICKY_EOF (1<<10) /* EOF occurred on this channel because + * we saw the input eofChar. This bit + * prevents clearing of the EOF bit + * before every input operation. */ +#define CHANNEL_BLOCKED (1<<11) /* EWOULDBLOCK or EAGAIN occurred + * on this channel. This bit is + * cleared before every input or + * output operation. */ +#define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input + * translation mode and the last + * byte seen was a "\r". */ +#define CHANNEL_DEAD (1<<13) /* The channel has been closed by + * the exit handler (on exit) but + * not deallocated. When any IO + * operation sees this flag on a + * channel, it does not call driver + * level functions to avoid referring + * to deallocated data. */ +#define CHANNEL_GETS_BLOCKED (1<<14) /* The last input operation was a gets + * that failed to get a comlete line. + * When set, file events will not be + * delivered for buffered data unless + * an EOL is present. */ + +/* + * For each channel handler registered in a call to Tcl_CreateChannelHandler, + * there is one record of the following type. All of records for a specific + * channel are chained together in a singly linked list which is stored in + * the channel structure. + */ + +typedef struct ChannelHandler { + Channel *chanPtr; /* The channel structure for this channel. */ + int mask; /* Mask of desired events. */ + Tcl_ChannelProc *proc; /* Procedure to call in the type of + * Tcl_CreateChannelHandler. */ + ClientData clientData; /* Argument to pass to procedure. */ + struct ChannelHandler *nextPtr; + /* Next one in list of registered handlers. */ +} ChannelHandler; + +/* + * This structure keeps track of the current ChannelHandler being invoked in + * the current invocation of ChannelHandlerEventProc. There is a potential + * problem if a ChannelHandler is deleted while it is the current one, since + * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this + * problem, structures of the type below indicate the next handler to be + * processed for any (recursively nested) dispatches in progress. The + * nextHandlerPtr field is updated if the handler being pointed to is deleted. + * The nextPtr field is used to chain together all recursive invocations, so + * that Tcl_DeleteChannelHandler can find all the recursively nested + * invocations of ChannelHandlerEventProc and compare the handler being + * deleted against the NEXT handler to be invoked in that invocation; when it + * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr + * field of the structure to the next handler. + */ + +typedef struct NextChannelHandler { + ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in + * this invocation. */ + struct NextChannelHandler *nestedHandlerPtr; + /* Next nested invocation of + * ChannelHandlerEventProc. */ +} NextChannelHandler; + +/* + * This variable holds the list of nested ChannelHandlerEventProc invocations. + */ + +static NextChannelHandler *nestedHandlerPtr = (NextChannelHandler *) NULL; + +/* + * List of all channels currently open. + */ + +static Channel *firstChanPtr = (Channel *) NULL; + +/* + * Has a channel exit handler been created yet? + */ + +static int channelExitHandlerCreated = 0; + +/* + * The following structure describes the event that is added to the Tcl + * event queue by the channel handler check procedure. + */ + +typedef struct ChannelHandlerEvent { + Tcl_Event header; /* Standard header for all events. */ + Channel *chanPtr; /* The channel that is ready. */ + int readyMask; /* Events that have occurred. */ +} ChannelHandlerEvent; + +/* + * Static variables to hold channels for stdin, stdout and stderr. + */ + +static Tcl_Channel stdinChannel = NULL; +static int stdinInitialized = 0; +static Tcl_Channel stdoutChannel = NULL; +static int stdoutInitialized = 0; +static Tcl_Channel stderrChannel = NULL; +static int stderrInitialized = 0; + +/* + * Static functions in this file: + */ + +static void ChannelEventScriptInvoker _ANSI_ARGS_(( + ClientData clientData, int flags)); +static void ChannelTimerProc _ANSI_ARGS_(( + ClientData clientData)); +static void CheckForStdChannelsBeingClosed _ANSI_ARGS_(( + Tcl_Channel chan)); +static void CleanupChannelHandlers _ANSI_ARGS_(( + Tcl_Interp *interp, Channel *chanPtr)); +static int CloseChannel _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int errorCode)); +static void CloseChannelsOnExit _ANSI_ARGS_((ClientData data)); +static int CopyAndTranslateBuffer _ANSI_ARGS_(( + Channel *chanPtr, char *result, int space)); +static int CopyData _ANSI_ARGS_((CopyState *csPtr, int mask)); +static void CopyEventProc _ANSI_ARGS_((ClientData clientData, + int mask)); +static void CreateScriptRecord _ANSI_ARGS_(( + Tcl_Interp *interp, Channel *chanPtr, + int mask, char *script)); +static void DeleteChannelTable _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int mask)); +static void DiscardInputQueued _ANSI_ARGS_(( + Channel *chanPtr, int discardSavedBuffers)); +static void DiscardOutputQueued _ANSI_ARGS_(( + Channel *chanPtr)); +static int DoRead _ANSI_ARGS_((Channel *chanPtr, char *srcPtr, + int slen)); +static int DoWrite _ANSI_ARGS_((Channel *chanPtr, char *srcPtr, + int slen)); +static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int calledFromAsyncFlush)); +static Tcl_HashTable *GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp)); +static int GetEOL _ANSI_ARGS_((Channel *chanPtr)); +static int GetInput _ANSI_ARGS_((Channel *chanPtr)); +static void RecycleBuffer _ANSI_ARGS_((Channel *chanPtr, + ChannelBuffer *bufPtr, int mustDiscard)); +static int ScanBufferForEOL _ANSI_ARGS_((Channel *chanPtr, + ChannelBuffer *bufPtr, + Tcl_EolTranslation translation, int eofChar, + int *bytesToEOLPtr, int *crSeenPtr)); +static int ScanInputForEOL _ANSI_ARGS_((Channel *chanPtr, + int *bytesQueuedPtr)); +static int SetBlockMode _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int mode)); +static void StopCopy _ANSI_ARGS_((CopyState *csPtr)); +static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr)); +static int CheckForDeadChannel _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chan)); + +/* + *---------------------------------------------------------------------- + * + * SetBlockMode -- + * + * This function sets the blocking mode for a channel and updates + * the state flags. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Modifies the blocking mode of the channel and possibly generates + * an error. + * + *---------------------------------------------------------------------- + */ + +static int +SetBlockMode(interp, chanPtr, mode) + Tcl_Interp *interp; /* Interp for error reporting. */ + Channel *chanPtr; /* Channel to modify. */ + int mode; /* One of TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + int result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + mode); + } + if (result != 0) { + Tcl_SetErrno(result); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "error setting blocking mode: ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + if (mode == TCL_MODE_BLOCKING) { + chanPtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED)); + } else { + chanPtr->flags |= CHANNEL_NONBLOCKING; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetStdChannel -- + * + * This function is used to change the channels that are used + * for stdin/stdout/stderr in new interpreters. + * + * Results: + * None + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetStdChannel(channel, type) + Tcl_Channel channel; + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + switch (type) { + case TCL_STDIN: + stdinInitialized = 1; + stdinChannel = channel; + break; + case TCL_STDOUT: + stdoutInitialized = 1; + stdoutChannel = channel; + break; + case TCL_STDERR: + stderrInitialized = 1; + stderrChannel = channel; + break; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetStdChannel -- + * + * Returns the specified standard channel. + * + * Results: + * Returns the specified standard channel, or NULL. + * + * Side effects: + * May cause the creation of a standard channel and the underlying + * file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_GetStdChannel(type) + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + Tcl_Channel channel = NULL; + + /* + * If the channels were not created yet, create them now and + * store them in the static variables. Note that we need to set + * stdinInitialized before calling TclGetDefaultStdChannel in order + * to avoid recursive loops when TclGetDefaultStdChannel calls + * Tcl_CreateChannel. + */ + + switch (type) { + case TCL_STDIN: + if (!stdinInitialized) { + stdinChannel = TclGetDefaultStdChannel(TCL_STDIN); + stdinInitialized = 1; + + /* + * Artificially bump the refcount to ensure that the channel + * is only closed on exit. + * + * NOTE: Must only do this if stdinChannel is not NULL. It + * can be NULL in situations where Tcl is unable to connect + * to the standard input. + */ + + if (stdinChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + stdinChannel); + } + } + channel = stdinChannel; + break; + case TCL_STDOUT: + if (!stdoutInitialized) { + stdoutChannel = TclGetDefaultStdChannel(TCL_STDOUT); + stdoutInitialized = 1; + + /* + * Artificially bump the refcount to ensure that the channel + * is only closed on exit. + * + * NOTE: Must only do this if stdoutChannel is not NULL. It + * can be NULL in situations where Tcl is unable to connect + * to the standard output. + */ + + if (stdoutChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + stdoutChannel); + } + } + channel = stdoutChannel; + break; + case TCL_STDERR: + if (!stderrInitialized) { + stderrChannel = TclGetDefaultStdChannel(TCL_STDERR); + stderrInitialized = 1; + + /* + * Artificially bump the refcount to ensure that the channel + * is only closed on exit. + * + * NOTE: Must only do this if stderrChannel is not NULL. It + * can be NULL in situations where Tcl is unable to connect + * to the standard error. + */ + + if (stderrChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + stderrChannel); + } + } + channel = stderrChannel; + break; + } + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateCloseHandler + * + * Creates a close callback which will be called when the channel is + * closed. + * + * Results: + * None. + * + * Side effects: + * Causes the callback to be called in the future when the channel + * will be closed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateCloseHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to create the + * close callback. */ + Tcl_CloseProc *proc; /* The callback routine to call when the + * channel will be closed. */ + ClientData clientData; /* Arbitrary data to pass to the + * close callback. */ +{ + Channel *chanPtr; + CloseCallback *cbPtr; + + chanPtr = (Channel *) chan; + + cbPtr = (CloseCallback *) ckalloc((unsigned) sizeof(CloseCallback)); + cbPtr->proc = proc; + cbPtr->clientData = clientData; + + cbPtr->nextPtr = chanPtr->closeCbPtr; + chanPtr->closeCbPtr = cbPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCloseHandler -- + * + * Removes a callback that would have been called on closing + * the channel. If there is no matching callback then this + * function has no effect. + * + * Results: + * None. + * + * Side effects: + * The callback will not be called in the future when the channel + * is eventually closed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteCloseHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to cancel the + * close callback. */ + Tcl_CloseProc *proc; /* The procedure for the callback to + * remove. */ + ClientData clientData; /* The callback data for the callback + * to remove. */ +{ + Channel *chanPtr; + CloseCallback *cbPtr, *cbPrevPtr; + + chanPtr = (Channel *) chan; + for (cbPtr = chanPtr->closeCbPtr, cbPrevPtr = (CloseCallback *) NULL; + cbPtr != (CloseCallback *) NULL; + cbPtr = cbPtr->nextPtr) { + if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) { + if (cbPrevPtr == (CloseCallback *) NULL) { + chanPtr->closeCbPtr = cbPtr->nextPtr; + } + ckfree((char *) cbPtr); + break; + } else { + cbPrevPtr = cbPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CloseChannelsOnExit -- + * + * Closes all the existing channels, on exit. This routine is called + * during exit processing. + * + * Results: + * None. + * + * Side effects: + * Closes all channels. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +CloseChannelsOnExit(clientData) + ClientData clientData; /* NULL - unused. */ +{ + Channel *chanPtr; /* Iterates over open channels. */ + Channel *nextChanPtr; /* Iterates over open channels. */ + + + for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + + /* + * Set the channel back into blocking mode to ensure that we wait + * for all data to flush out. + */ + + (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, + "-blocking", "on"); + + if ((chanPtr == (Channel *) stdinChannel) || + (chanPtr == (Channel *) stdoutChannel) || + (chanPtr == (Channel *) stderrChannel)) { + + /* + * Decrement the refcount which was earlier artificially bumped + * up to keep the channel from being closed. + */ + + chanPtr->refCount--; + } + + if (chanPtr->refCount <= 0) { + + /* + * Close it only if the refcount indicates that the channel is not + * referenced from any interpreter. If it is, that interpreter will + * close the channel when it gets destroyed. + */ + + (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + + } else { + + /* + * The refcount is greater than zero, so flush the channel. + */ + + Tcl_Flush((Tcl_Channel) chanPtr); + + /* + * Call the device driver to actually close the underlying + * device for this channel. + */ + + (chanPtr->typePtr->closeProc) (chanPtr->instanceData, + (Tcl_Interp *) NULL); + + /* + * Finally, we clean up the fields in the channel data structure + * since all of them have been deleted already. We mark the + * channel with CHANNEL_DEAD to prevent any further IO operations + * on it. + */ + + chanPtr->instanceData = (ClientData) NULL; + chanPtr->flags |= CHANNEL_DEAD; + } + } + + /* + * Reinitialize all the variables to the initial state: + */ + + firstChanPtr = (Channel *) NULL; + nestedHandlerPtr = (NextChannelHandler *) NULL; + channelExitHandlerCreated = 0; + stdinChannel = NULL; + stdinInitialized = 0; + stdoutChannel = NULL; + stdoutInitialized = 0; + stderrChannel = NULL; + stderrInitialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * GetChannelTable -- + * + * Gets and potentially initializes the channel table for an + * interpreter. If it is initializing the table it also inserts + * channels for stdin, stdout and stderr if the interpreter is + * trusted. + * + * Results: + * A pointer to the hash table created, for use by the caller. + * + * Side effects: + * Initializes the channel table for an interpreter. May create + * channels for stdin, stdout and stderr. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashTable * +GetChannelTable(interp) + Tcl_Interp *interp; +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_Channel stdinChan, stdoutChan, stderrChan; + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); + + (void) Tcl_SetAssocData(interp, "tclIO", + (Tcl_InterpDeleteProc *) DeleteChannelTable, + (ClientData) hTblPtr); + + /* + * If the interpreter is trusted (not "safe"), insert channels + * for stdin, stdout and stderr (possibly creating them in the + * process). + */ + + if (Tcl_IsSafe(interp) == 0) { + stdinChan = Tcl_GetStdChannel(TCL_STDIN); + if (stdinChan != NULL) { + Tcl_RegisterChannel(interp, stdinChan); + } + stdoutChan = Tcl_GetStdChannel(TCL_STDOUT); + if (stdoutChan != NULL) { + Tcl_RegisterChannel(interp, stdoutChan); + } + stderrChan = Tcl_GetStdChannel(TCL_STDERR); + if (stderrChan != NULL) { + Tcl_RegisterChannel(interp, stderrChan); + } + } + + } + return hTblPtr; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteChannelTable -- + * + * Deletes the channel table for an interpreter, closing any open + * channels whose refcount reaches zero. This procedure is invoked + * when an interpreter is deleted, via the AssocData cleanup + * mechanism. + * + * Results: + * None. + * + * Side effects: + * Deletes the hash table of channels. May close channels. May flush + * output on closed channels. Removes any channeEvent handlers that were + * registered in this interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteChannelTable(clientData, interp) + ClientData clientData; /* The per-interpreter data structure. */ + Tcl_Interp *interp; /* The interpreter being deleted. */ +{ + Tcl_HashTable *hTblPtr; /* The hash table. */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* Channel being deleted. */ + EventScriptRecord *sPtr, *prevPtr, *nextPtr; + /* Variables to loop over all channel events + * registered, to delete the ones that refer + * to the interpreter being deleted. */ + + /* + * Delete all the registered channels - this will close channels whose + * refcount reaches zero. + */ + + hTblPtr = (Tcl_HashTable *) clientData; + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { + + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + + /* + * Remove any fileevents registered in this interpreter. + */ + + for (sPtr = chanPtr->scriptRecordPtr, + prevPtr = (EventScriptRecord *) NULL; + sPtr != (EventScriptRecord *) NULL; + sPtr = nextPtr) { + nextPtr = sPtr->nextPtr; + if (sPtr->interp == interp) { + if (prevPtr == (EventScriptRecord *) NULL) { + chanPtr->scriptRecordPtr = nextPtr; + } else { + prevPtr->nextPtr = nextPtr; + } + + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) sPtr); + + ckfree(sPtr->script); + ckfree((char *) sPtr); + } else { + prevPtr = sPtr; + } + } + + /* + * Cannot call Tcl_UnregisterChannel because that procedure calls + * Tcl_GetAssocData to get the channel table, which might already + * be inaccessible from the interpreter structure. Instead, we + * emulate the behavior of Tcl_UnregisterChannel directly here. + */ + + Tcl_DeleteHashEntry(hPtr); + chanPtr->refCount--; + if (chanPtr->refCount <= 0) { + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + (void) Tcl_Close(interp, (Tcl_Channel) chanPtr); + } + } + } + Tcl_DeleteHashTable(hTblPtr); + ckfree((char *) hTblPtr); +} + +/* + *---------------------------------------------------------------------- + * + * CheckForStdChannelsBeingClosed -- + * + * Perform special handling for standard channels being closed. When + * given a standard channel, if the refcount is now 1, it means that + * the last reference to the standard channel is being explicitly + * closed. Now bump the refcount artificially down to 0, to ensure the + * normal handling of channels being closed will occur. Also reset the + * static pointer to the channel to NULL, to avoid dangling references. + * + * Results: + * None. + * + * Side effects: + * Manipulates the refcount on standard channels. May smash the global + * static pointer to a standard channel. + * + *---------------------------------------------------------------------- + */ + +static void +CheckForStdChannelsBeingClosed(chan) + Tcl_Channel chan; +{ + Channel *chanPtr = (Channel *) chan; + + if ((chan == stdinChannel) && (stdinInitialized)) { + if (chanPtr->refCount < 2) { + chanPtr->refCount = 0; + stdinChannel = NULL; + return; + } + } else if ((chan == stdoutChannel) && (stdoutInitialized)) { + if (chanPtr->refCount < 2) { + chanPtr->refCount = 0; + stdoutChannel = NULL; + return; + } + } else if ((chan == stderrChannel) && (stderrInitialized)) { + if (chanPtr->refCount < 2) { + chanPtr->refCount = 0; + stderrChannel = NULL; + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnregisterChannel -- + * + * Deletes the hash entry for a channel associated with an interpreter. + * If the interpreter given as argument is NULL, it only decrements the + * reference count. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes the hash entry for a channel associated with an interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UnregisterChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which channel is defined. */ + Tcl_Channel chan; /* Channel to delete. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* The real IO channel. */ + + chanPtr = (Channel *) chan; + + if (interp != (Tcl_Interp *) NULL) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + hPtr = Tcl_FindHashEntry(hTblPtr, chanPtr->channelName); + if (hPtr == (Tcl_HashEntry *) NULL) { + return TCL_OK; + } + if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { + return TCL_OK; + } + Tcl_DeleteHashEntry(hPtr); + + /* + * Remove channel handlers that refer to this interpreter, so that they + * will not be present if the actual close is delayed and more events + * happen on the channel. This may occur if the channel is shared + * between several interpreters, or if the channel has async + * flushing active. + */ + + CleanupChannelHandlers(interp, chanPtr); + } + + chanPtr->refCount--; + + /* + * Perform special handling for standard channels being closed. If the + * refCount is now 1 it means that the last reference to the standard + * channel is being explicitly closed, so bump the refCount down + * artificially to 0. This will ensure that the channel is actually + * closed, below. Also set the static pointer to NULL for the channel. + */ + + CheckForStdChannelsBeingClosed(chan); + + /* + * If the refCount reached zero, close the actual channel. + */ + + if (chanPtr->refCount <= 0) { + + /* + * Ensure that if there is another buffer, it gets flushed + * whether or not we are doing a background flush. + */ + + if ((chanPtr->curOutPtr != NULL) && + (chanPtr->curOutPtr->nextAdded > + chanPtr->curOutPtr->nextRemoved)) { + chanPtr->flags |= BUFFER_READY; + } + chanPtr->flags |= CHANNEL_CLOSED; + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + if (Tcl_Close(interp, chan) != TCL_OK) { + return TCL_ERROR; + } + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegisterChannel -- + * + * Adds an already-open channel to the channel table of an interpreter. + * If the interpreter passed as argument is NULL, it only increments + * the channel refCount. + * + * Results: + * None. + * + * Side effects: + * May increment the reference count of a channel. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_RegisterChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which to add the channel. */ + Tcl_Channel chan; /* The channel to add to this interpreter + * channel table. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + int new; /* Is the hash entry new or does it exist? */ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + + if (chanPtr->channelName == (char *) NULL) { + panic("Tcl_RegisterChannel: channel without name"); + } + if (interp != (Tcl_Interp *) NULL) { + hTblPtr = GetChannelTable(interp); + hPtr = Tcl_CreateHashEntry(hTblPtr, chanPtr->channelName, &new); + if (new == 0) { + if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { + return; + } + panic("Tcl_RegisterChannel: duplicate channel names"); + } + Tcl_SetHashValue(hPtr, (ClientData) chanPtr); + } + chanPtr->refCount++; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannel -- + * + * Finds an existing Tcl_Channel structure by name in a given + * interpreter. This function is public because it is used by + * channel-type-specific functions. + * + * Results: + * A Tcl_Channel or NULL on failure. If failed, interp->result + * contains an error message. It also returns, in modePtr, the + * modes in which the channel is opened. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_GetChannel(interp, chanName, modePtr) + Tcl_Interp *interp; /* Interpreter in which to find or create + * the channel. */ + char *chanName; /* The name of the channel. */ + int *modePtr; /* Where to store the mode in which the + * channel was opened? Will contain an ORed + * combination of TCL_READABLE and + * TCL_WRITABLE, if non-NULL. */ +{ + Channel *chanPtr; /* The actual channel. */ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + char *name; /* Translated name. */ + + /* + * Substitute "stdin", etc. Note that even though we immediately + * find the channel using Tcl_GetStdChannel, we still need to look + * it up in the specified interpreter to ensure that it is present + * in the channel table. Otherwise, safe interpreters would always + * have access to the standard channels. + */ + + name = chanName; + if ((chanName[0] == 's') && (chanName[1] == 't')) { + chanPtr = NULL; + if (strcmp(chanName, "stdin") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDIN); + } else if (strcmp(chanName, "stdout") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDOUT); + } else if (strcmp(chanName, "stderr") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDERR); + } + if (chanPtr != NULL) { + name = chanPtr->channelName; + } + } + + hTblPtr = GetChannelTable(interp); + hPtr = Tcl_FindHashEntry(hTblPtr, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(interp, "can not find channel named \"", + chanName, "\"", (char *) NULL); + return NULL; + } + + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (modePtr != NULL) { + *modePtr = (chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)); + } + + return (Tcl_Channel) chanPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateChannel -- + * + * Creates a new entry in the hash table for a Tcl_Channel + * record. + * + * Results: + * Returns the new Tcl_Channel. + * + * Side effects: + * Creates a new Tcl_Channel instance and inserts it into the + * hash table. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_CreateChannel(typePtr, chanName, instanceData, mask) + Tcl_ChannelType *typePtr; /* The channel type record. */ + char *chanName; /* Name of channel to record. */ + ClientData instanceData; /* Instance specific data. */ + int mask; /* TCL_READABLE & TCL_WRITABLE to indicate + * if the channel is readable, writable. */ +{ + Channel *chanPtr; /* The channel structure newly created. */ + + chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); + + if (chanName != (char *) NULL) { + chanPtr->channelName = ckalloc((unsigned) (strlen(chanName) + 1)); + strcpy(chanPtr->channelName, chanName); + } else { + panic("Tcl_CreateChannel: NULL channel name"); + } + + chanPtr->flags = mask; + + /* + * Set the channel up initially in AUTO input translation mode to + * accept "\n", "\r" and "\r\n". Output translation mode is set to + * a platform specific default value. The eofChar is set to 0 for both + * input and output, so that Tcl does not look for an in-file EOF + * indicator (e.g. ^Z) and does not append an EOF indicator to files. + */ + + chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + chanPtr->inEofChar = 0; + chanPtr->outEofChar = 0; + + chanPtr->unreportedError = 0; + chanPtr->instanceData = instanceData; + chanPtr->typePtr = typePtr; + chanPtr->refCount = 0; + chanPtr->closeCbPtr = (CloseCallback *) NULL; + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + chanPtr->outQueueHead = (ChannelBuffer *) NULL; + chanPtr->outQueueTail = (ChannelBuffer *) NULL; + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + chanPtr->inQueueHead = (ChannelBuffer *) NULL; + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + chanPtr->chPtr = (ChannelHandler *) NULL; + chanPtr->interestMask = 0; + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; + chanPtr->timer = NULL; + chanPtr->csPtr = NULL; + + /* + * Link the channel into the list of all channels; create an on-exit + * handler if there is not one already, to close off all the channels + * in the list on exit. + */ + + chanPtr->nextChanPtr = firstChanPtr; + firstChanPtr = chanPtr; + + if (!channelExitHandlerCreated) { + channelExitHandlerCreated = 1; + Tcl_CreateExitHandler(CloseChannelsOnExit, (ClientData) NULL); + } + + /* + * Install this channel in the first empty standard channel slot, if + * the channel was previously closed explicitly. + */ + + if ((stdinChannel == NULL) && (stdinInitialized == 1)) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDIN); + Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + } else if ((stdoutChannel == NULL) && (stdoutInitialized == 1)) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDOUT); + Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + } else if ((stderrChannel == NULL) && (stderrInitialized == 1)) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDERR); + Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + } + return (Tcl_Channel) chanPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelMode -- + * + * Computes a mask indicating whether the channel is open for + * reading and writing. + * + * Results: + * An OR-ed combination of TCL_READABLE and TCL_WRITABLE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelMode(chan) + Tcl_Channel chan; /* The channel for which the mode is + * being computed. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return (chanPtr->flags & (TCL_READABLE | TCL_WRITABLE)); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelName -- + * + * Returns the string identifying the channel name. + * + * Results: + * The string containing the channel name. This memory is + * owned by the generic layer and should not be modified by + * the caller. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetChannelName(chan) + Tcl_Channel chan; /* The channel for which to return the name. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->channelName; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelType -- + * + * Given a channel structure, returns the channel type structure. + * + * Results: + * Returns a pointer to the channel type structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_ChannelType * +Tcl_GetChannelType(chan) + Tcl_Channel chan; /* The channel to return type for. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->typePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelHandle -- + * + * Returns an OS handle associated with a channel. + * + * Results: + * Returns TCL_OK and places the handle in handlePtr, or returns + * TCL_ERROR on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelHandle(chan, direction, handlePtr) + Tcl_Channel chan; /* The channel to get file from. */ + int direction; /* TCL_WRITABLE or TCL_READABLE. */ + ClientData *handlePtr; /* Where to store handle */ +{ + Channel *chanPtr; /* The actual channel. */ + ClientData handle; + int result; + + chanPtr = (Channel *) chan; + result = (chanPtr->typePtr->getHandleProc)(chanPtr->instanceData, + direction, &handle); + if (handlePtr) { + *handlePtr = handle; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelInstanceData -- + * + * Returns the client data associated with a channel. + * + * Results: + * The client data. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_GetChannelInstanceData(chan) + Tcl_Channel chan; /* Channel for which to return client data. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->instanceData; +} + +/* + *---------------------------------------------------------------------- + * + * RecycleBuffer -- + * + * Helper function to recycle input and output buffers. Ensures + * that two input buffers are saved (one in the input queue and + * another in the saveInBufPtr field) and that curOutPtr is set + * to a buffer. Only if these conditions are met is the buffer + * freed to the OS. + * + * Results: + * None. + * + * Side effects: + * May free a buffer to the OS. + * + *---------------------------------------------------------------------- + */ + +static void +RecycleBuffer(chanPtr, bufPtr, mustDiscard) + Channel *chanPtr; /* Channel for which to recycle buffers. */ + ChannelBuffer *bufPtr; /* The buffer to recycle. */ + int mustDiscard; /* If nonzero, free the buffer to the + * OS, always. */ +{ + /* + * Do we have to free the buffer to the OS? + */ + + if (mustDiscard) { + ckfree((char *) bufPtr); + return; + } + + /* + * Only save buffers for the input queue if the channel is readable. + */ + + if (chanPtr->flags & TCL_READABLE) { + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + chanPtr->inQueueHead = bufPtr; + chanPtr->inQueueTail = bufPtr; + goto keepit; + } + if (chanPtr->saveInBufPtr == (ChannelBuffer *) NULL) { + chanPtr->saveInBufPtr = bufPtr; + goto keepit; + } + } + + /* + * Only save buffers for the output queue if the channel is writable. + */ + + if (chanPtr->flags & TCL_WRITABLE) { + if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { + chanPtr->curOutPtr = bufPtr; + goto keepit; + } + } + + /* + * If we reached this code we return the buffer to the OS. + */ + + ckfree((char *) bufPtr); + return; + +keepit: + bufPtr->nextRemoved = 0; + bufPtr->nextAdded = 0; + bufPtr->nextPtr = (ChannelBuffer *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DiscardOutputQueued -- + * + * Discards all output queued in the output queue of a channel. + * + * Results: + * None. + * + * Side effects: + * Recycles buffers. + * + *---------------------------------------------------------------------- + */ + +static void +DiscardOutputQueued(chanPtr) + Channel *chanPtr; /* The channel for which to discard output. */ +{ + ChannelBuffer *bufPtr; + + while (chanPtr->outQueueHead != (ChannelBuffer *) NULL) { + bufPtr = chanPtr->outQueueHead; + chanPtr->outQueueHead = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, 0); + } + chanPtr->outQueueHead = (ChannelBuffer *) NULL; + chanPtr->outQueueTail = (ChannelBuffer *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * CheckForDeadChannel -- + * + * This function checks is a given channel is Dead. + * (A channel that has been closed but not yet deallocated.) + * + * Results: + * True (1) if channel is Dead, False (0) if channel is Ok + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +static int +CheckForDeadChannel(interp, chanPtr) + Tcl_Interp *interp; /* For error reporting (can be NULL) */ + Channel *chanPtr; /* The channel to check. */ +{ + if (chanPtr->flags & CHANNEL_DEAD) { + Tcl_SetErrno(EINVAL); + if (interp) { + Tcl_AppendResult(interp, + "unable to access channel: invalid channel", + (char *) NULL); + } + return 1; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * FlushChannel -- + * + * This function flushes as much of the queued output as is possible + * now. If calledFromAsyncFlush is nonzero, it is being called in an + * event handler to flush channel output asynchronously. + * + * Results: + * 0 if successful, else the error code that was returned by the + * channel type operation. + * + * Side effects: + * May produce output on a channel. May block indefinitely if the + * channel is synchronous. May schedule an async flush on the channel. + * May recycle memory for buffers in the output queue. + * + *---------------------------------------------------------------------- + */ + +static int +FlushChannel(interp, chanPtr, calledFromAsyncFlush) + Tcl_Interp *interp; /* For error reporting during close. */ + Channel *chanPtr; /* The channel to flush on. */ + int calledFromAsyncFlush; /* If nonzero then we are being + * called from an asynchronous + * flush callback. */ +{ + ChannelBuffer *bufPtr; /* Iterates over buffered output + * queue. */ + int toWrite; /* Amount of output data in current + * buffer available to be written. */ + int written; /* Amount of output data actually + * written in current round. */ + int errorCode; /* Stores POSIX error codes from + * channel driver operations. */ + errorCode = 0; + + /* + * Prevent writing on a dead channel -- a channel that has been closed + * but not yet deallocated. This can occur if the exit handler for the + * channel deallocation runs before all channels are deregistered in + * all interpreters. + */ + + if (CheckForDeadChannel(interp,chanPtr)) return -1; + + /* + * Loop over the queued buffers and attempt to flush as + * much as possible of the queued output to the channel. + */ + + while (1) { + + /* + * If the queue is empty and there is a ready current buffer, OR if + * the current buffer is full, then move the current buffer to the + * queue. + */ + + if (((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded == chanPtr->curOutPtr->bufSize)) + || ((chanPtr->flags & BUFFER_READY) && + (chanPtr->outQueueHead == (ChannelBuffer *) NULL))) { + chanPtr->flags &= (~(BUFFER_READY)); + chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; + if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { + chanPtr->outQueueHead = chanPtr->curOutPtr; + } else { + chanPtr->outQueueTail->nextPtr = chanPtr->curOutPtr; + } + chanPtr->outQueueTail = chanPtr->curOutPtr; + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + } + bufPtr = chanPtr->outQueueHead; + + /* + * If we are not being called from an async flush and an async + * flush is active, we just return without producing any output. + */ + + if ((!calledFromAsyncFlush) && + (chanPtr->flags & BG_FLUSH_SCHEDULED)) { + return 0; + } + + /* + * If the output queue is still empty, break out of the while loop. + */ + + if (bufPtr == (ChannelBuffer *) NULL) { + break; /* Out of the "while (1)". */ + } + + /* + * Produce the output on the channel. + */ + + toWrite = bufPtr->nextAdded - bufPtr->nextRemoved; + written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData, + bufPtr->buf + bufPtr->nextRemoved, toWrite, &errorCode); + + /* + * If the write failed completely attempt to start the asynchronous + * flush mechanism and break out of this loop - do not attempt to + * write any more output at this time. + */ + + if (written < 0) { + + /* + * If the last attempt to write was interrupted, simply retry. + */ + + if (errorCode == EINTR) { + errorCode = 0; + continue; + } + + /* + * If the channel is non-blocking and we would have blocked, + * start a background flushing handler and break out of the loop. + */ + + if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + chanPtr->flags |= BG_FLUSH_SCHEDULED; + UpdateInterest(chanPtr); + } + errorCode = 0; + break; + } else { + panic("Blocking channel driver did not block on output"); + } + } + + /* + * Decide whether to report the error upwards or defer it. + */ + + if (calledFromAsyncFlush) { + if (chanPtr->unreportedError == 0) { + chanPtr->unreportedError = errorCode; + } + } else { + Tcl_SetErrno(errorCode); + if (interp != NULL) { + Tcl_SetResult(interp, + Tcl_PosixError(interp), TCL_VOLATILE); + } + } + + /* + * When we get an error we throw away all the output + * currently queued. + */ + + DiscardOutputQueued(chanPtr); + continue; + } + + bufPtr->nextRemoved += written; + + /* + * If this buffer is now empty, recycle it. + */ + + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + chanPtr->outQueueHead = bufPtr->nextPtr; + if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { + chanPtr->outQueueTail = (ChannelBuffer *) NULL; + } + RecycleBuffer(chanPtr, bufPtr, 0); + } + } /* Closes "while (1)". */ + + /* + * If the queue became empty and we have the asynchronous flushing + * mechanism active, cancel the asynchronous flushing. + */ + + if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && + (chanPtr->flags & BG_FLUSH_SCHEDULED)) { + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + (chanPtr->typePtr->watchProc)(chanPtr->instanceData, + chanPtr->interestMask); + } + + /* + * If the channel is flagged as closed, delete it when the refCount + * drops to zero, the output queue is empty and there is no output + * in the current output buffer. + */ + + if ((chanPtr->flags & CHANNEL_CLOSED) && (chanPtr->refCount <= 0) && + (chanPtr->outQueueHead == (ChannelBuffer *) NULL) && + ((chanPtr->curOutPtr == (ChannelBuffer *) NULL) || + (chanPtr->curOutPtr->nextAdded == + chanPtr->curOutPtr->nextRemoved))) { + return CloseChannel(interp, chanPtr, errorCode); + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * CloseChannel -- + * + * Utility procedure to close a channel and free its associated + * resources. + * + * Results: + * 0 on success or a POSIX error code if the operation failed. + * + * Side effects: + * May close the actual channel; may free memory. + * + *---------------------------------------------------------------------- + */ + +static int +CloseChannel(interp, chanPtr, errorCode) + Tcl_Interp *interp; /* For error reporting. */ + Channel *chanPtr; /* The channel to close. */ + int errorCode; /* Status of operation so far. */ +{ + int result = 0; /* Of calling driver close + * operation. */ + Channel *prevChanPtr; /* Preceding channel in list of + * all channels - used to splice a + * channel out of the list on close. */ + + if (chanPtr == NULL) { + return result; + } + + /* + * No more input can be consumed so discard any leftover input. + */ + + DiscardInputQueued(chanPtr, 1); + + /* + * Discard a leftover buffer in the current output buffer field. + */ + + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + ckfree((char *) chanPtr->curOutPtr); + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + } + + /* + * The caller guarantees that there are no more buffers + * queued for output. + */ + + if (chanPtr->outQueueHead != (ChannelBuffer *) NULL) { + panic("TclFlush, closed channel: queued output left"); + } + + /* + * If the EOF character is set in the channel, append that to the + * output device. + */ + + if ((chanPtr->outEofChar != 0) && (chanPtr->flags & TCL_WRITABLE)) { + int dummy; + char c; + + c = (char) chanPtr->outEofChar; + (chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy); + } + + /* + * Remove TCL_READABLE and TCL_WRITABLE from chanPtr->flags, so + * that close callbacks can not do input or output (assuming they + * squirreled the channel away in their clientData). This also + * prevents infinite loops if the callback calls any C API that + * could call FlushChannel. + */ + + chanPtr->flags &= (~(TCL_READABLE|TCL_WRITABLE)); + + /* + * Splice this channel out of the list of all channels. + */ + + if (chanPtr == firstChanPtr) { + firstChanPtr = chanPtr->nextChanPtr; + } else { + for (prevChanPtr = firstChanPtr; + (prevChanPtr != (Channel *) NULL) && + (prevChanPtr->nextChanPtr != chanPtr); + prevChanPtr = prevChanPtr->nextChanPtr) { + /* Empty loop body. */ + } + if (prevChanPtr == (Channel *) NULL) { + panic("FlushChannel: damaged channel list"); + } + prevChanPtr->nextChanPtr = chanPtr->nextChanPtr; + } + + /* + * OK, close the channel itself. + */ + + result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp); + + if (chanPtr->channelName != (char *) NULL) { + ckfree(chanPtr->channelName); + } + + /* + * If we are being called synchronously, report either + * any latent error on the channel or the current error. + */ + + if (chanPtr->unreportedError != 0) { + errorCode = chanPtr->unreportedError; + } + if (errorCode == 0) { + errorCode = result; + if (errorCode != 0) { + Tcl_SetErrno(errorCode); + } + } + + /* + * Cancel any outstanding timer. + */ + + Tcl_DeleteTimerHandler(chanPtr->timer); + + /* + * Mark the channel as deleted by clearing the type structure. + */ + + chanPtr->typePtr = NULL; + + Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Close -- + * + * Closes a channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Closes the channel if this is the last reference. + * + * NOTE: + * Tcl_Close removes the channel as far as the user is concerned. + * However, it may continue to exist for a while longer if it has + * a background flush scheduled. The device itself is eventually + * closed and the channel record removed, in CloseChannel, above. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_Close(interp, chan) + Tcl_Interp *interp; /* Interpreter for errors. */ + Tcl_Channel chan; /* The channel being closed. Must + * not be referenced in any + * interpreter. */ +{ + ChannelHandler *chPtr, *chNext; /* Iterate over channel handlers. */ + CloseCallback *cbPtr; /* Iterate over close callbacks + * for this channel. */ + EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */ + Channel *chanPtr; /* The real IO channel. */ + int result; /* Of calling FlushChannel. */ + NextChannelHandler *nhPtr; + + if (chan == (Tcl_Channel) NULL) { + return TCL_OK; + } + + /* + * Perform special handling for standard channels being closed. If the + * refCount is now 1 it means that the last reference to the standard + * channel is being explicitly closed, so bump the refCount down + * artificially to 0. This will ensure that the channel is actually + * closed, below. Also set the static pointer to NULL for the channel. + */ + + CheckForStdChannelsBeingClosed(chan); + + chanPtr = (Channel *) chan; + if (chanPtr->refCount > 0) { + panic("called Tcl_Close on channel with refCount > 0"); + } + + /* + * Remove any references to channel handlers for this channel that + * may be about to be invoked. + */ + + for (nhPtr = nestedHandlerPtr; + nhPtr != (NextChannelHandler *) NULL; + nhPtr = nhPtr->nestedHandlerPtr) { + if (nhPtr->nextHandlerPtr && + (nhPtr->nextHandlerPtr->chanPtr == chanPtr)) { + nhPtr->nextHandlerPtr = NULL; + } + } + + /* + * Remove all the channel handler records attached to the channel + * itself. + */ + + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chNext) { + chNext = chPtr->nextPtr; + ckfree((char *) chPtr); + } + chanPtr->chPtr = (ChannelHandler *) NULL; + + + /* + * Cancel any pending copy operation. + */ + + StopCopy(chanPtr->csPtr); + + /* + * Must set the interest mask now to 0, otherwise infinite loops + * will occur if Tcl_DoOneEvent is called before the channel is + * finally deleted in FlushChannel. This can happen if the channel + * has a background flush active. + */ + + chanPtr->interestMask = 0; + + /* + * Remove any EventScript records for this channel. + */ + + for (ePtr = chanPtr->scriptRecordPtr; + ePtr != (EventScriptRecord *) NULL; + ePtr = eNextPtr) { + eNextPtr = ePtr->nextPtr; + ckfree(ePtr->script); + ckfree((char *) ePtr); + } + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + + /* + * Invoke the registered close callbacks and delete their records. + */ + + while (chanPtr->closeCbPtr != (CloseCallback *) NULL) { + cbPtr = chanPtr->closeCbPtr; + chanPtr->closeCbPtr = cbPtr->nextPtr; + (cbPtr->proc) (cbPtr->clientData); + ckfree((char *) cbPtr); + } + + /* + * Ensure that the last output buffer will be flushed. + */ + + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > chanPtr->curOutPtr->nextRemoved)) { + chanPtr->flags |= BUFFER_READY; + } + + /* + * The call to FlushChannel will flush any queued output and invoke + * the close function of the channel driver, or it will set up the + * channel to be flushed and closed asynchronously. + */ + + chanPtr->flags |= CHANNEL_CLOSED; + result = FlushChannel(interp, chanPtr, 0); + if (result != 0) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Write -- + * + * Puts a sequence of characters into an output buffer, may queue the + * buffer for output if it gets full, and also remembers whether the + * current buffer is ready e.g. if it contains a newline and we are in + * line buffering mode. + * + * Results: + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. + * + * Side effects: + * May buffer up output and may cause output to be produced on the + * channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Write(chan, srcPtr, slen) + Tcl_Channel chan; /* The channel to buffer output for. */ + char *srcPtr; /* Output to buffer. */ + int slen; /* Its length. Negative means + * the output is null terminated + * and we must compute its length. */ +{ + Channel *chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * If the channel is not open for writing punt. + */ + + if (!(chanPtr->flags & TCL_WRITABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If the channel is in the middle of a background copy, fail. + */ + + if (chanPtr->csPtr) { + Tcl_SetErrno(EBUSY); + return -1; + } + + /* + * If length passed is negative, assume that the output is null terminated + * and compute its length. + */ + + if (slen < 0) { + slen = strlen(srcPtr); + } + + return DoWrite(chanPtr, srcPtr, slen); +} + +/* + *---------------------------------------------------------------------- + * + * DoWrite -- + * + * Puts a sequence of characters into an output buffer, may queue the + * buffer for output if it gets full, and also remembers whether the + * current buffer is ready e.g. if it contains a newline and we are in + * line buffering mode. + * + * Results: + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. + * + * Side effects: + * May buffer up output and may cause output to be produced on the + * channel. + * + *---------------------------------------------------------------------- + */ + +static int +DoWrite(chanPtr, srcPtr, slen) + Channel *chanPtr; /* The channel to buffer output for. */ + char *srcPtr; /* Data to write. */ + int slen; /* Number of bytes to write. */ +{ + ChannelBuffer *outBufPtr; /* Current output buffer. */ + int foundNewline; /* Did we find a newline in output? */ + char *dPtr, *sPtr; /* Search variables for newline. */ + int crsent; /* In CRLF eol translation mode, + * remember the fact that a CR was + * output to the channel without + * its following NL. */ + int i; /* Loop index for newline search. */ + int destCopied; /* How many bytes were used in this + * destination buffer to hold the + * output? */ + int totalDestCopied; /* How many bytes total were + * copied to the channel buffer? */ + int srcCopied; /* How many bytes were copied from + * the source string? */ + char *destPtr; /* Where in line to copy to? */ + + /* + * If we are in network (or windows) translation mode, record the fact + * that we have not yet sent a CR to the channel. + */ + + crsent = 0; + + /* + * Loop filling buffers and flushing them until all output has been + * consumed. + */ + + srcCopied = 0; + totalDestCopied = 0; + + while (slen > 0) { + + /* + * Make sure there is a current output buffer to accept output. + */ + + if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { + chanPtr->curOutPtr = (ChannelBuffer *) ckalloc((unsigned) + (CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); + chanPtr->curOutPtr->nextAdded = 0; + chanPtr->curOutPtr->nextRemoved = 0; + chanPtr->curOutPtr->bufSize = chanPtr->bufSize; + chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; + } + + outBufPtr = chanPtr->curOutPtr; + + destCopied = outBufPtr->bufSize - outBufPtr->nextAdded; + if (destCopied > slen) { + destCopied = slen; + } + + destPtr = outBufPtr->buf + outBufPtr->nextAdded; + switch (chanPtr->outputTranslation) { + case TCL_TRANSLATE_LF: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); + break; + case TCL_TRANSLATE_CR: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); + for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { + if (*dPtr == '\n') { + *dPtr = '\r'; + } + } + break; + case TCL_TRANSLATE_CRLF: + for (srcCopied = 0, dPtr = destPtr, sPtr = srcPtr; + dPtr < destPtr + destCopied; + dPtr++, sPtr++, srcCopied++) { + if (*sPtr == '\n') { + if (crsent) { + *dPtr = '\n'; + crsent = 0; + } else { + *dPtr = '\r'; + crsent = 1; + sPtr--, srcCopied--; + } + } else { + *dPtr = *sPtr; + } + } + break; + case TCL_TRANSLATE_AUTO: + panic("Tcl_Write: AUTO output translation mode not supported"); + default: + panic("Tcl_Write: unknown output translation mode"); + } + + /* + * The current buffer is ready for output if it is full, or if it + * contains a newline and this channel is line-buffered, or if it + * contains any output and this channel is unbuffered. + */ + + outBufPtr->nextAdded += destCopied; + if (!(chanPtr->flags & BUFFER_READY)) { + if (outBufPtr->nextAdded == outBufPtr->bufSize) { + chanPtr->flags |= BUFFER_READY; + } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + for (sPtr = srcPtr, i = 0, foundNewline = 0; + (i < srcCopied) && (!foundNewline); + i++, sPtr++) { + if (*sPtr == '\n') { + foundNewline = 1; + break; + } + } + if (foundNewline) { + chanPtr->flags |= BUFFER_READY; + } + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + chanPtr->flags |= BUFFER_READY; + } + } + + totalDestCopied += srcCopied; + srcPtr += srcCopied; + slen -= srcCopied; + + if (chanPtr->flags & BUFFER_READY) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } + } + } /* Closes "while" */ + + return totalDestCopied; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Flush -- + * + * Flushes output data on a channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May flush output queued on this channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Flush(chan) + Tcl_Channel chan; /* The Channel to flush. */ +{ + int result; /* Of calling FlushChannel. */ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return TCL_ERROR; + } + + /* + * If the channel is not open for writing punt. + */ + + if (!(chanPtr->flags & TCL_WRITABLE)) { + Tcl_SetErrno(EACCES); + return TCL_ERROR; + } + + /* + * If the channel is in the middle of a background copy, fail. + */ + + if (chanPtr->csPtr) { + Tcl_SetErrno(EBUSY); + return -1; + } + + /* + * Force current output buffer to be output also. + */ + + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > 0)) { + chanPtr->flags |= BUFFER_READY; + } + + result = FlushChannel(NULL, chanPtr, 0); + if (result != 0) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DiscardInputQueued -- + * + * Discards any input read from the channel but not yet consumed + * by Tcl reading commands. + * + * Results: + * None. + * + * Side effects: + * May discard input from the channel. If discardLastBuffer is zero, + * leaves one buffer in place for back-filling. + * + *---------------------------------------------------------------------- + */ + +static void +DiscardInputQueued(chanPtr, discardSavedBuffers) + Channel *chanPtr; /* Channel on which to discard + * the queued input. */ + int discardSavedBuffers; /* If non-zero, discard all buffers including + * last one. */ +{ + ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */ + + bufPtr = chanPtr->inQueueHead; + chanPtr->inQueueHead = (ChannelBuffer *) NULL; + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) { + nxtPtr = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, discardSavedBuffers); + } + + /* + * If discardSavedBuffers is nonzero, must also discard any previously + * saved buffer in the saveInBufPtr field. + */ + + if (discardSavedBuffers) { + if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { + ckfree((char *) chanPtr->saveInBufPtr); + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * GetInput -- + * + * Reads input data from a device or file into an input buffer. + * + * Results: + * A Posix error code or 0. + * + * Side effects: + * Reads from the underlying device. + * + *---------------------------------------------------------------------- + */ + +static int +GetInput(chanPtr) + Channel *chanPtr; /* Channel to read input from. */ +{ + int toRead; /* How much to read? */ + int result; /* Of calling driver. */ + int nread; /* How much was read from channel? */ + ChannelBuffer *bufPtr; /* New buffer to add to input queue. */ + + /* + * Prevent reading from a dead channel -- a channel that has been closed + * but not yet deallocated, which can happen if the exit handler for + * channel cleanup has run but the channel is still registered in some + * interpreter. + */ + + if (CheckForDeadChannel(NULL,chanPtr)) return EINVAL; + + /* + * See if we can fill an existing buffer. If we can, read only + * as much as will fit in it. Otherwise allocate a new buffer, + * add it to the input queue and attempt to fill it to the max. + */ + + if ((chanPtr->inQueueTail != (ChannelBuffer *) NULL) && + (chanPtr->inQueueTail->nextAdded < chanPtr->inQueueTail->bufSize)) { + bufPtr = chanPtr->inQueueTail; + toRead = bufPtr->bufSize - bufPtr->nextAdded; + } else { + if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { + bufPtr = chanPtr->saveInBufPtr; + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + } else { + bufPtr = (ChannelBuffer *) ckalloc( + ((unsigned) CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); + bufPtr->bufSize = chanPtr->bufSize; + } + bufPtr->nextRemoved = 0; + bufPtr->nextAdded = 0; + toRead = bufPtr->bufSize; + if (chanPtr->inQueueTail == (ChannelBuffer *) NULL) { + chanPtr->inQueueHead = bufPtr; + } else { + chanPtr->inQueueTail->nextPtr = bufPtr; + } + chanPtr->inQueueTail = bufPtr; + bufPtr->nextPtr = (ChannelBuffer *) NULL; + } + + /* + * If EOF is set, we should avoid calling the driver because on some + * platforms it is impossible to read from a device after EOF. + */ + + if (chanPtr->flags & CHANNEL_EOF) { + return 0; + } + + nread = (chanPtr->typePtr->inputProc) (chanPtr->instanceData, + bufPtr->buf + bufPtr->nextAdded, toRead, &result); + + if (nread == 0) { + chanPtr->flags |= CHANNEL_EOF; + } else if (nread < 0) { + if ((result == EWOULDBLOCK) || (result == EAGAIN)) { + chanPtr->flags |= CHANNEL_BLOCKED; + result = EAGAIN; + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + Tcl_SetErrno(result); + } else { + panic("Blocking channel driver did not block on input"); + } + } else { + Tcl_SetErrno(result); + } + return result; + } else { + bufPtr->nextAdded += nread; + + /* + * If we get a short read, signal up that we may be BLOCKED. We + * should avoid calling the driver because on some platforms we + * will block in the low level reading code even though the + * channel is set into nonblocking mode. + */ + + if (nread < toRead) { + chanPtr->flags |= CHANNEL_BLOCKED; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * CopyAndTranslateBuffer -- + * + * Copy at most one buffer of input to the result space, doing + * eol translations according to mode in effect currently. + * + * Results: + * Number of characters (as opposed to bytes) copied. May return + * zero if no input is available to be translated. + * + * Side effects: + * Consumes buffered input. May deallocate one buffer. + * + *---------------------------------------------------------------------- + */ + +static int +CopyAndTranslateBuffer(chanPtr, result, space) + Channel *chanPtr; /* The channel from which to read input. */ + char *result; /* Where to store the copied input. */ + int space; /* How many bytes are available in result + * to store the copied input? */ +{ + int bytesInBuffer; /* How many bytes are available to be + * copied in the current input buffer? */ + int copied; /* How many characters were already copied + * into the destination space? */ + ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ + char curByte; /* The byte we are currently translating. */ + int i; /* Iterates over the copied input looking + * for the input eofChar. */ + + /* + * If there is no input at all, return zero. The invariant is that either + * there is no buffer in the queue, or if the first buffer is empty, it + * is also the last buffer (and thus there is no input in the queue). + * Note also that if the buffer is empty, we leave it in the queue. + */ + + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + return 0; + } + bufPtr = chanPtr->inQueueHead; + bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + copied = 0; + switch (chanPtr->inputTranslation) { + case TCL_TRANSLATE_LF: + + if (space == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer. + */ + + memcpy((VOID *) result, + (VOID *)(bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + break; + + case TCL_TRANSLATE_CR: + + if (space == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer, then + * replace all \r with \n. + */ + + memcpy((VOID *) result, + (VOID *)(bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + for (copied = 0; copied < space; copied++) { + if (result[copied] == '\r') { + result[copied] = '\n'; + } + } + break; + + case TCL_TRANSLATE_CRLF: + + /* + * If there is a held-back "\r" at EOF, produce it now. + */ + + if (space == 0) { + if ((chanPtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == + (INPUT_SAW_CR | CHANNEL_EOF)) { + result[0] = '\r'; + chanPtr->flags &= (~(INPUT_SAW_CR)); + return 1; + } + return 0; + } + + /* + * Copy the current chunk and replace "\r\n" with "\n" + * (but not standalone "\r"!). + */ + + for (copied = 0; + (copied < space) && + (bufPtr->nextRemoved < bufPtr->nextAdded); + copied++) { + curByte = bufPtr->buf[bufPtr->nextRemoved]; + bufPtr->nextRemoved++; + if (curByte == '\r') { + if (chanPtr->flags & INPUT_SAW_CR) { + result[copied] = '\r'; + } else { + chanPtr->flags |= INPUT_SAW_CR; + copied--; + } + } else if (curByte == '\n') { + chanPtr->flags &= (~(INPUT_SAW_CR)); + result[copied] = '\n'; + } else { + if (chanPtr->flags & INPUT_SAW_CR) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + result[copied] = '\r'; + bufPtr->nextRemoved--; + } else { + result[copied] = curByte; + } + } + } + break; + + case TCL_TRANSLATE_AUTO: + + if (space == 0) { + return 0; + } + + /* + * Loop over the current buffer, converting "\r" and "\r\n" + * to "\n". + */ + + for (copied = 0; + (copied < space) && + (bufPtr->nextRemoved < bufPtr->nextAdded); ) { + curByte = bufPtr->buf[bufPtr->nextRemoved]; + bufPtr->nextRemoved++; + if (curByte == '\r') { + result[copied] = '\n'; + copied++; + if (bufPtr->nextRemoved < bufPtr->nextAdded) { + if (bufPtr->buf[bufPtr->nextRemoved] == '\n') { + bufPtr->nextRemoved++; + } + chanPtr->flags &= (~(INPUT_SAW_CR)); + } else { + chanPtr->flags |= INPUT_SAW_CR; + } + } else { + if (curByte == '\n') { + if (!(chanPtr->flags & INPUT_SAW_CR)) { + result[copied] = '\n'; + copied++; + } + } else { + result[copied] = curByte; + copied++; + } + chanPtr->flags &= (~(INPUT_SAW_CR)); + } + } + break; + + default: + panic("unknown eol translation mode"); + } + + /* + * If an in-stream EOF character is set for this channel,, check that + * the input we copied so far does not contain the EOF char. If it does, + * copy only up to and excluding that character. + */ + + if (chanPtr->inEofChar != 0) { + for (i = 0; i < copied; i++) { + if (result[i] == (char) chanPtr->inEofChar) { + break; + } + } + if (i < copied) { + + /* + * Set sticky EOF so that no further input is presented + * to the caller. + */ + + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + + /* + * Reset the start of valid data in the input buffer to the + * position of the eofChar, so that subsequent reads will + * encounter it immediately. First we set it to the position + * of the last byte consumed if all result bytes were the + * product of one input byte; since it is possible that "\r\n" + * contracted to "\n" in the result, we have to search back + * from that position until we find the eofChar, because it + * is possible that its actual position in the buffer is n + * bytes further back (n is the number of "\r\n" sequences + * that were contracted to "\n" in the result). + */ + + bufPtr->nextRemoved -= (copied - i); + while ((bufPtr->nextRemoved > 0) && + (bufPtr->buf[bufPtr->nextRemoved] != + (char) chanPtr->inEofChar)) { + bufPtr->nextRemoved--; + } + copied = i; + } + } + + /* + * If the current buffer is empty recycle it. + */ + + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + chanPtr->inQueueHead = bufPtr->nextPtr; + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + } + RecycleBuffer(chanPtr, bufPtr, 0); + } + + /* + * Return the number of characters copied into the result buffer. + * This may be different from the number of bytes consumed, because + * of EOL translations. + */ + + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * ScanBufferForEOL -- + * + * Scans one buffer for EOL according to the specified EOL + * translation mode. If it sees the input eofChar for the channel + * it stops also. + * + * Results: + * TRUE if EOL is found, FALSE otherwise. Also sets output parameter + * bytesToEOLPtr to the number of bytes so far to EOL, and crSeenPtr + * to whether a "\r" was seen. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ScanBufferForEOL(chanPtr, bufPtr, translation, eofChar, bytesToEOLPtr, + crSeenPtr) + Channel *chanPtr; + ChannelBuffer *bufPtr; /* Buffer to scan for EOL. */ + Tcl_EolTranslation translation; /* Translation mode to use. */ + int eofChar; /* EOF char to look for. */ + int *bytesToEOLPtr; /* Running counter. */ + int *crSeenPtr; /* Has "\r" been seen? */ +{ + char *rPtr; /* Iterates over input string. */ + char *sPtr; /* Where to stop search? */ + int EOLFound; + int bytesToEOL; + + for (EOLFound = 0, rPtr = bufPtr->buf + bufPtr->nextRemoved, + sPtr = bufPtr->buf + bufPtr->nextAdded, + bytesToEOL = *bytesToEOLPtr; + (!EOLFound) && (rPtr < sPtr); + rPtr++) { + switch (translation) { + case TCL_TRANSLATE_AUTO: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else if (*rPtr == '\n') { + + /* + * CopyAndTranslateBuffer wants to know the length + * of the result, not the input. The input is one + * larger because "\r\n" shrinks to "\n". + */ + + if (!(*crSeenPtr)) { + bytesToEOL++; + EOLFound = 1; + } else { + + /* + * This is a lf at the begining of a buffer + * where the previous buffer ended in a cr. + * Consume this lf because we've already emitted + * the newline for this crlf sequence. ALSO, if + * bytesToEOL is 0 (which means that we are at the + * first character of the scan), unset the + * INPUT_SAW_CR flag in the channel, because we + * already handled it; leaving it set would cause + * CopyAndTranslateBuffer to potentially consume + * another lf if one follows the current byte. + */ + + bufPtr->nextRemoved++; + *crSeenPtr = 0; + chanPtr->flags &= (~(INPUT_SAW_CR)); + } + } else if (*rPtr == '\r') { + bytesToEOL++; + EOLFound = 1; + } else { + *crSeenPtr = 0; + bytesToEOL++; + } + break; + case TCL_TRANSLATE_LF: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else { + if (*rPtr == '\n') { + EOLFound = 1; + } + bytesToEOL++; + } + break; + case TCL_TRANSLATE_CR: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else { + if (*rPtr == '\r') { + EOLFound = 1; + } + bytesToEOL++; + } + break; + case TCL_TRANSLATE_CRLF: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else if (*rPtr == '\n') { + + /* + * CopyAndTranslateBuffer wants to know the length + * of the result, not the input. The input is one + * larger because crlf shrinks to lf. + */ + + if (*crSeenPtr) { + EOLFound = 1; + } else { + bytesToEOL++; + } + } else { + if (*rPtr == '\r') { + *crSeenPtr = 1; + } else { + *crSeenPtr = 0; + } + bytesToEOL++; + } + break; + default: + panic("unknown eol translation mode"); + } + } + + *bytesToEOLPtr = bytesToEOL; + return EOLFound; +} + +/* + *---------------------------------------------------------------------- + * + * ScanInputForEOL -- + * + * Scans queued input for chanPtr for an end of line (according to the + * current EOL translation mode) and returns the number of bytes + * upto and including the end of line, or -1 if none was found. + * + * Results: + * Count of bytes upto and including the end of line if one is present + * or -1 if none was found. Also returns in an output parameter the + * number of bytes queued if no end of line was found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ScanInputForEOL(chanPtr, bytesQueuedPtr) + Channel *chanPtr; /* Channel for which to scan queued + * input for end of line. */ + int *bytesQueuedPtr; /* Where to store the number of bytes + * currently queued if no end of line + * was found. */ +{ + ChannelBuffer *bufPtr; /* Iterates over queued buffers. */ + int bytesToEOL; /* How many bytes to end of line? */ + int EOLFound; /* Did we find an end of line? */ + int crSeen; /* Did we see a "\r" in CRLF mode? */ + + *bytesQueuedPtr = 0; + bytesToEOL = 0; + EOLFound = 0; + for (bufPtr = chanPtr->inQueueHead, + crSeen = (chanPtr->flags & INPUT_SAW_CR) ? 1 : 0; + (!EOLFound) && (bufPtr != (ChannelBuffer *) NULL); + bufPtr = bufPtr->nextPtr) { + EOLFound = ScanBufferForEOL(chanPtr, bufPtr, chanPtr->inputTranslation, + chanPtr->inEofChar, &bytesToEOL, &crSeen); + } + + if (EOLFound == 0) { + *bytesQueuedPtr = bytesToEOL; + return -1; + } + return bytesToEOL; +} + +/* + *---------------------------------------------------------------------- + * + * GetEOL -- + * + * Accumulate input into the channel input buffer queue until an + * end of line has been seen. + * + * Results: + * Number of bytes buffered (at least 1) or -1 on failure. + * + * Side effects: + * Consumes input from the channel. + * + *---------------------------------------------------------------------- + */ + +static int +GetEOL(chanPtr) + Channel *chanPtr; /* Channel to queue input on. */ +{ + int bytesToEOL; /* How many bytes in buffer up to and + * including the end of line? */ + int bytesQueued; /* How many bytes are queued currently + * in the input chain of the channel? */ + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Punt if the channel is not opened for reading. + */ + + if (!(chanPtr->flags & TCL_READABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If the channel is in the middle of a background copy, fail. + */ + + if (chanPtr->csPtr) { + Tcl_SetErrno(EBUSY); + return -1; + } + + /* + * If we have not encountered a sticky EOF, clear the EOF bit + * (sticky EOF is set if we have seen the input eofChar, to prevent + * reading beyond the eofChar). Also, always clear the BLOCKED bit. + * We want to discover these conditions anew in each operation. + */ + + if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { + chanPtr->flags &= (~(CHANNEL_EOF)); + } + chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_GETS_BLOCKED)); + + while (1) { + bytesToEOL = ScanInputForEOL(chanPtr, &bytesQueued); + if (bytesToEOL > 0) { + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + return bytesToEOL; + } + if (chanPtr->flags & CHANNEL_EOF) { + /* + * Boundary case where cr was at the end of the previous buffer + * and this buffer just has a newline. At EOF our caller wants + * to see -1 for the line length. + */ + return (bytesQueued == 0) ? -1 : bytesQueued ; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + goto blocked; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + } + if (GetInput(chanPtr) != 0) { + goto blocked; + } + } + + blocked: + + /* + * We didn't get a complete line so we need to indicate to UpdateInterest + * that the gets blocked. It will wait for more data instead of firing + * a timer, avoiding a busy wait. This is where we are assuming that the + * next operation is a gets. No more file events will be delivered on + * this channel until new data arrives or some operation is performed + * on the channel (e.g. gets, read, fconfigure) that changes the blocking + * state. Note that this means a file event will not be delivered even + * though a read would be able to consume the buffered data. + */ + + chanPtr->flags |= CHANNEL_GETS_BLOCKED; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Read -- + * + * Reads a given number of characters from a channel. + * + * Results: + * The number of characters read, or -1 on error. Use Tcl_GetErrno() + * to retrieve the error code for the error that occurred. + * + * Side effects: + * May cause input to be buffered. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Read(chan, bufPtr, toRead) + Tcl_Channel chan; /* The channel from which to read. */ + char *bufPtr; /* Where to store input read. */ + int toRead; /* Maximum number of characters to read. */ +{ + Channel *chanPtr; /* The real IO channel. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Punt if the channel is not opened for reading. + */ + + if (!(chanPtr->flags & TCL_READABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If the channel is in the middle of a background copy, fail. + */ + + if (chanPtr->csPtr) { + Tcl_SetErrno(EBUSY); + return -1; + } + + return DoRead(chanPtr, bufPtr, toRead); +} + +/* + *---------------------------------------------------------------------- + * + * DoRead -- + * + * Reads a given number of characters from a channel. + * + * Results: + * The number of characters read, or -1 on error. Use Tcl_GetErrno() + * to retrieve the error code for the error that occurred. + * + * Side effects: + * May cause input to be buffered. + * + *---------------------------------------------------------------------- + */ + +static int +DoRead(chanPtr, bufPtr, toRead) + Channel *chanPtr; /* The channel from which to read. */ + char *bufPtr; /* Where to store input read. */ + int toRead; /* Maximum number of characters to read. */ +{ + int copied; /* How many characters were copied into + * the result string? */ + int copiedNow; /* How many characters were copied from + * the current input buffer? */ + int result; /* Of calling GetInput. */ + + /* + * If we have not encountered a sticky EOF, clear the EOF bit. Either + * way clear the BLOCKED bit. We want to discover these anew during + * each operation. + */ + + if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { + chanPtr->flags &= (~(CHANNEL_EOF)); + } + chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_GETS_BLOCKED)); + + for (copied = 0; copied < toRead; copied += copiedNow) { + copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied, + toRead - copied); + if (copiedNow == 0) { + if (chanPtr->flags & CHANNEL_EOF) { + goto done; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + goto done; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + } + result = GetInput(chanPtr); + if (result != 0) { + if (result != EAGAIN) { + copied = -1; + } + goto done; + } + } + } + + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + + done: + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Gets -- + * + * Reads a complete line of input from the channel into a + * Tcl_DString. + * + * Results: + * Length of line read or -1 if error, EOF or blocked. If -1, use + * Tcl_GetErrno() to retrieve the POSIX error code for the + * error or condition that occurred. + * + * Side effects: + * May flush output on the channel. May cause input to be + * consumed from the channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Gets(chan, lineRead) + Tcl_Channel chan; /* Channel from which to read. */ + Tcl_DString *lineRead; /* The characters of the line read + * (excluding the terminating newline if + * present) will be appended to this + * DString. The caller must have initialized + * it and is responsible for managing the + * storage. */ +{ + Channel *chanPtr; /* The channel to read from. */ + char *buf; /* Points into DString where data + * will be stored. */ + int offset; /* Offset from start of DString at + * which to append the line just read. */ + int copiedTotal; /* Accumulates total length of input copied. */ + int copiedNow; /* How many bytes were copied from the + * current input buffer? */ + int lineLen; /* Length of line read, including the + * translated newline. If this is zero + * and neither EOF nor BLOCKED is set, + * the current line is empty. */ + + chanPtr = (Channel *) chan; + + lineLen = GetEOL(chanPtr); + if (lineLen < 0) { + copiedTotal = -1; + goto done; + } + offset = Tcl_DStringLength(lineRead); + Tcl_DStringSetLength(lineRead, lineLen + offset); + buf = Tcl_DStringValue(lineRead) + offset; + + for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { + copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, + lineLen - copiedTotal); + } + if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { + copiedTotal--; + } + Tcl_DStringSetLength(lineRead, copiedTotal + offset); + + done: + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); + return copiedTotal; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetsObj -- + * + * Reads a complete line of input from the channel into a + * string object. + * + * Results: + * Length of line read or -1 if error, EOF or blocked. If -1, use + * Tcl_GetErrno() to retrieve the POSIX error code for the + * error or condition that occurred. + * + * Side effects: + * May flush output on the channel. May cause input to be + * consumed from the channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetsObj(chan, objPtr) + Tcl_Channel chan; /* Channel from which to read. */ + Tcl_Obj *objPtr; /* The characters of the line read + * (excluding the terminating newline if + * present) will be appended to this + * object. The caller must have initialized + * it and is responsible for managing the + * storage. */ +{ + Channel *chanPtr; /* The channel to read from. */ + char *buf; /* Points into DString where data + * will be stored. */ + int offset; /* Offset from start of DString at + * which to append the line just read. */ + int copiedTotal; /* Accumulates total length of input copied. */ + int copiedNow; /* How many bytes were copied from the + * current input buffer? */ + int lineLen; /* Length of line read, including the + * translated newline. If this is zero + * and neither EOF nor BLOCKED is set, + * the current line is empty. */ + + chanPtr = (Channel *) chan; + + lineLen = GetEOL(chanPtr); + if (lineLen < 0) { + copiedTotal = -1; + goto done; + } + + (void) Tcl_GetStringFromObj(objPtr, &offset); + Tcl_SetObjLength(objPtr, lineLen + offset); + buf = Tcl_GetStringFromObj(objPtr, NULL) + offset; + + for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { + copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, + lineLen - copiedTotal); + } + if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { + copiedTotal--; + } + Tcl_SetObjLength(objPtr, copiedTotal + offset); + + done: + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); + return copiedTotal; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Ungets -- + * + * Causes the supplied string to be added to the input queue of + * the channel, at either the head or tail of the queue. + * + * Results: + * The number of bytes stored in the channel, or -1 on error. + * + * Side effects: + * Adds input to the input queue of a channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Ungets(chan, str, len, atEnd) + Tcl_Channel chan; /* The channel for which to add the input. */ + char *str; /* The input itself. */ + int len; /* The length of the input. */ + int atEnd; /* If non-zero, add at end of queue; otherwise + * add at head of queue. */ +{ + Channel *chanPtr; /* The real IO channel. */ + ChannelBuffer *bufPtr; /* Buffer to contain the data. */ + int i; + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Punt if the channel is not opened for reading. + */ + + if (!(chanPtr->flags & TCL_READABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If the channel is in the middle of a background copy, fail. + */ + + if (chanPtr->csPtr) { + Tcl_SetErrno(EBUSY); + return -1; + } + + /* + * If we have encountered a sticky EOF, just punt without storing. + * (sticky EOF is set if we have seen the input eofChar, to prevent + * reading beyond the eofChar). Otherwise, clear the EOF flags, and + * clear the BLOCKED bit. We want to discover these conditions anew + * in each operation. + */ + + if (chanPtr->flags & CHANNEL_STICKY_EOF) { + return len; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF)); + + bufPtr = (ChannelBuffer *) ckalloc((unsigned) + (CHANNELBUFFER_HEADER_SIZE + len)); + for (i = 0; i < len; i++) { + bufPtr->buf[i] = str[i]; + } + bufPtr->bufSize = len; + bufPtr->nextAdded = len; + bufPtr->nextRemoved = 0; + + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + bufPtr->nextPtr = (ChannelBuffer *) NULL; + chanPtr->inQueueHead = bufPtr; + chanPtr->inQueueTail = bufPtr; + } else if (atEnd) { + bufPtr->nextPtr = (ChannelBuffer *) NULL; + chanPtr->inQueueTail->nextPtr = bufPtr; + chanPtr->inQueueTail = bufPtr; + } else { + bufPtr->nextPtr = chanPtr->inQueueHead; + chanPtr->inQueueHead = bufPtr; + } + + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); + return len; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Seek -- + * + * Implements seeking on Tcl Channels. This is a public function + * so that other C facilities may be implemented on top of it. + * + * Results: + * The new access point or -1 on error. If error, use Tcl_GetErrno() + * to retrieve the POSIX error code for the error that occurred. + * + * Side effects: + * May flush output on the channel. May discard queued input. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Seek(chan, offset, mode) + Tcl_Channel chan; /* The channel on which to seek. */ + int offset; /* Offset to seek to. */ + int mode; /* Relative to which location to seek? */ +{ + Channel *chanPtr; /* The real IO channel. */ + ChannelBuffer *bufPtr; + int inputBuffered, outputBuffered; + int result; /* Of device driver operations. */ + int curPos; /* Position on the device. */ + int wasAsync; /* Was the channel nonblocking before the + * seek operation? If so, must restore to + * nonblocking mode after the seek. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Disallow seek on channels that are open for neither writing nor + * reading (e.g. socket server channels). + */ + + if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If the channel is in the middle of a background copy, fail. + */ + + if (chanPtr->csPtr) { + Tcl_SetErrno(EBUSY); + return -1; + } + + /* + * Disallow seek on dead channels -- channels that have been closed but + * not yet been deallocated. Such channels can be found if the exit + * handler for channel cleanup has run but the channel is still + * registered in an interpreter. + */ + + if (CheckForDeadChannel(NULL,chanPtr)) return -1; + + /* + * Disallow seek on channels whose type does not have a seek procedure + * defined. This means that the channel does not support seeking. + */ + + if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * Compute how much input and output is buffered. If both input and + * output is buffered, cannot compute the current position. + */ + + for (bufPtr = chanPtr->inQueueHead, inputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + for (bufPtr = chanPtr->outQueueHead, outputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > chanPtr->curOutPtr->nextRemoved)) { + chanPtr->flags |= BUFFER_READY; + outputBuffered += + (chanPtr->curOutPtr->nextAdded - chanPtr->curOutPtr->nextRemoved); + } + + if ((inputBuffered != 0) && (outputBuffered != 0)) { + Tcl_SetErrno(EFAULT); + return -1; + } + + /* + * If we are seeking relative to the current position, compute the + * corrected offset taking into account the amount of unread input. + */ + + if (mode == SEEK_CUR) { + offset -= inputBuffered; + } + + /* + * Discard any queued input - this input should not be read after + * the seek. + */ + + DiscardInputQueued(chanPtr, 0); + + /* + * Reset EOF and BLOCKED flags. We invalidate them by moving the + * access point. Also clear CR related flags. + */ + + chanPtr->flags &= + (~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR)); + + /* + * If the channel is in asynchronous output mode, switch it back + * to synchronous mode and cancel any async flush that may be + * scheduled. After the flush, the channel will be put back into + * asynchronous output mode. + */ + + wasAsync = 0; + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + wasAsync = 1; + result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + TCL_MODE_BLOCKING); + } + if (result != 0) { + Tcl_SetErrno(result); + return -1; + } + chanPtr->flags &= (~(CHANNEL_NONBLOCKING)); + if (chanPtr->flags & BG_FLUSH_SCHEDULED) { + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + } + } + + /* + * If the flush fails we cannot recover the original position. In + * that case the seek is not attempted because we do not know where + * the access position is - instead we return the error. FlushChannel + * has already called Tcl_SetErrno() to report the error upwards. + * If the flush succeeds we do the seek also. + */ + + if (FlushChannel(NULL, chanPtr, 0) != 0) { + curPos = -1; + } else { + + /* + * Now seek to the new position in the channel as requested by the + * caller. + */ + + curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, + (long) offset, mode, &result); + if (curPos == -1) { + Tcl_SetErrno(result); + } + } + + /* + * Restore to nonblocking mode if that was the previous behavior. + * + * NOTE: Even if there was an async flush active we do not restore + * it now because we already flushed all the queued output, above. + */ + + if (wasAsync) { + chanPtr->flags |= CHANNEL_NONBLOCKING; + result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + TCL_MODE_NONBLOCKING); + } + if (result != 0) { + Tcl_SetErrno(result); + return -1; + } + } + + return curPos; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Tell -- + * + * Returns the position of the next character to be read/written on + * this channel. + * + * Results: + * A nonnegative integer on success, -1 on failure. If failed, + * use Tcl_GetErrno() to retrieve the POSIX error code for the + * error that occurred. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Tell(chan) + Tcl_Channel chan; /* The channel to return pos for. */ +{ + Channel *chanPtr; /* The actual channel to tell on. */ + ChannelBuffer *bufPtr; + int inputBuffered, outputBuffered; + int result; /* Of calling device driver. */ + int curPos; /* Position on device. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Disallow tell on dead channels -- channels that have been closed but + * not yet been deallocated. Such channels can be found if the exit + * handler for channel cleanup has run but the channel is still + * registered in an interpreter. + */ + + if (CheckForDeadChannel(NULL,chanPtr)) return -1; + + /* + * Disallow tell on channels that are open for neither + * writing nor reading (e.g. socket server channels). + */ + + if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If the channel is in the middle of a background copy, fail. + */ + + if (chanPtr->csPtr) { + Tcl_SetErrno(EBUSY); + return -1; + } + + /* + * Disallow tell on channels whose type does not have a seek procedure + * defined. This means that the channel does not support seeking. + */ + + if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * Compute how much input and output is buffered. If both input and + * output is buffered, cannot compute the current position. + */ + + for (bufPtr = chanPtr->inQueueHead, inputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + for (bufPtr = chanPtr->outQueueHead, outputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > chanPtr->curOutPtr->nextRemoved)) { + chanPtr->flags |= BUFFER_READY; + outputBuffered += + (chanPtr->curOutPtr->nextAdded - chanPtr->curOutPtr->nextRemoved); + } + + if ((inputBuffered != 0) && (outputBuffered != 0)) { + Tcl_SetErrno(EFAULT); + return -1; + } + + /* + * Get the current position in the device and compute the position + * where the next character will be read or written. + */ + + curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, + (long) 0, SEEK_CUR, &result); + if (curPos == -1) { + Tcl_SetErrno(result); + return -1; + } + if (inputBuffered != 0) { + return (curPos - inputBuffered); + } + return (curPos + outputBuffered); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Eof -- + * + * Returns 1 if the channel is at EOF, 0 otherwise. + * + * Results: + * 1 or 0, always. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Eof(chan) + Tcl_Channel chan; /* Does this channel have EOF? */ +{ + Channel *chanPtr; /* The real channel structure. */ + + chanPtr = (Channel *) chan; + return ((chanPtr->flags & CHANNEL_STICKY_EOF) || + ((chanPtr->flags & CHANNEL_EOF) && (Tcl_InputBuffered(chan) == 0))) + ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InputBlocked -- + * + * Returns 1 if input is blocked on this channel, 0 otherwise. + * + * Results: + * 0 or 1, always. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InputBlocked(chan) + Tcl_Channel chan; /* Is this channel blocked? */ +{ + Channel *chanPtr; /* The real channel structure. */ + + chanPtr = (Channel *) chan; + return (chanPtr->flags & CHANNEL_BLOCKED) ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InputBuffered -- + * + * Returns the number of bytes of input currently buffered in the + * internal buffer of a channel. + * + * Results: + * The number of input bytes buffered, or zero if the channel is not + * open for reading. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InputBuffered(chan) + Tcl_Channel chan; /* The channel to query. */ +{ + Channel *chanPtr; + int bytesBuffered; + ChannelBuffer *bufPtr; + + chanPtr = (Channel *) chan; + for (bytesBuffered = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + bytesBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + return bytesBuffered; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetChannelBufferSize -- + * + * Sets the size of buffers to allocate to store input or output + * in the channel. The size must be between 10 bytes and 1 MByte. + * + * Results: + * None. + * + * Side effects: + * Sets the size of buffers subsequently allocated for this channel. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetChannelBufferSize(chan, sz) + Tcl_Channel chan; /* The channel whose buffer size + * to set. */ + int sz; /* The size to set. */ +{ + Channel *chanPtr; + + /* + * If the buffer size is smaller than 10 bytes or larger than one MByte, + * do not accept the requested size and leave the current buffer size. + */ + + if (sz < 10) { + return; + } + if (sz > (1024 * 1024)) { + return; + } + + chanPtr = (Channel *) chan; + chanPtr->bufSize = sz; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelBufferSize -- + * + * Retrieves the size of buffers to allocate for this channel. + * + * Results: + * The size. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelBufferSize(chan) + Tcl_Channel chan; /* The channel for which to find the + * buffer size. */ +{ + Channel *chanPtr; + + chanPtr = (Channel *) chan; + return chanPtr->bufSize; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_BadChannelOption -- + * + * This procedure generates a "bad option" error message in an + * (optional) interpreter. It is used by channel drivers when + * a invalid Set/Get option is requested. Its purpose is to concatenate + * the generic options list to the specific ones and factorize + * the generic options error message string. + * + * Results: + * TCL_ERROR. + * + * Side effects: + * An error message is generated in interp's result object to + * indicate that a command was invoked with the a bad option + * The message has the form + * bad option "blah": should be one of + * <...generic options...>+<...specific options...> + * "blah" is the optionName argument and "<specific options>" + * is a space separated list of specific option words. + * The function takes good care of inserting minus signs before + * each option, commas after, and an "or" before the last option. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_BadChannelOption(interp, optionName, optionList) + Tcl_Interp *interp; /* Current interpreter. (can be NULL)*/ + char *optionName; /* 'bad option' name */ + char *optionList; /* Specific options list to append + * to the standard generic options. + * can be NULL for generic options + * only. + */ +{ + if (interp) { + CONST char *genericopt = + "blocking buffering buffersize eofchar translation"; + char **argv; + int argc, i; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, (char *) genericopt, -1); + if (optionList && (*optionList)) { + Tcl_DStringAppend(&ds, " ", 1); + Tcl_DStringAppend(&ds, optionList, -1); + } + if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), + &argc, &argv) != TCL_OK) { + panic("malformed option list in channel driver"); + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad option \"", optionName, + "\": should be one of ", (char *) NULL); + argc--; + for (i = 0; i < argc; i++) { + Tcl_AppendResult(interp, "-", argv[i], ", ", (char *) NULL); + } + Tcl_AppendResult(interp, "or -", argv[i], (char *) NULL); + Tcl_DStringFree(&ds); + ckfree((char *) argv); + } + Tcl_SetErrno(EINVAL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelOption -- + * + * Gets a mode associated with an IO channel. If the optionName arg + * is non NULL, retrieves the value of that option. If the optionName + * arg is NULL, retrieves a list of alternating option names and + * values for the given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the + * string value of the option(s) returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelOption(interp, chan, optionName, dsPtr) + Tcl_Interp *interp; /* For error reporting - can be NULL. */ + Tcl_Channel chan; /* Channel on which to get option. */ + char *optionName; /* Option to get. */ + Tcl_DString *dsPtr; /* Where to store value(s). */ +{ + size_t len; /* Length of optionName string. */ + char optionVal[128]; /* Buffer for sprintf. */ + Channel *chanPtr = (Channel *) chan; + int flags; + + /* + * If we are in the middle of a background copy, use the saved flags. + */ + + if (chanPtr->csPtr) { + if (chanPtr == chanPtr->csPtr->readPtr) { + flags = chanPtr->csPtr->readFlags; + } else { + flags = chanPtr->csPtr->writeFlags; + } + } else { + flags = chanPtr->flags; + } + + /* + * Disallow options on dead channels -- channels that have been closed but + * not yet been deallocated. Such channels can be found if the exit + * handler for channel cleanup has run but the channel is still + * registered in an interpreter. + */ + + if (CheckForDeadChannel(interp,chanPtr)) return TCL_ERROR; + + /* + * If the optionName is NULL it means that we want a list of all + * options and values. + */ + + if (optionName == (char *) NULL) { + len = 0; + } else { + len = strlen(optionName); + } + + if ((len == 0) || ((len > 2) && (optionName[1] == 'b') && + (strncmp(optionName, "-blocking", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-blocking"); + } + Tcl_DStringAppendElement(dsPtr, + (flags & CHANNEL_NONBLOCKING) ? "0" : "1"); + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffering", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-buffering"); + } + if (flags & CHANNEL_LINEBUFFERED) { + Tcl_DStringAppendElement(dsPtr, "line"); + } else if (flags & CHANNEL_UNBUFFERED) { + Tcl_DStringAppendElement(dsPtr, "none"); + } else { + Tcl_DStringAppendElement(dsPtr, "full"); + } + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffersize", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-buffersize"); + } + TclFormatInt(optionVal, chanPtr->bufSize); + Tcl_DStringAppendElement(dsPtr, optionVal); + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || + ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-eofchar", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-eofchar"); + } + if (((flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { + Tcl_DStringStartSublist(dsPtr); + } + if (flags & TCL_READABLE) { + if (chanPtr->inEofChar == 0) { + Tcl_DStringAppendElement(dsPtr, ""); + } else { + char buf[4]; + + sprintf(buf, "%c", chanPtr->inEofChar); + Tcl_DStringAppendElement(dsPtr, buf); + } + } + if (flags & TCL_WRITABLE) { + if (chanPtr->outEofChar == 0) { + Tcl_DStringAppendElement(dsPtr, ""); + } else { + char buf[4]; + + sprintf(buf, "%c", chanPtr->outEofChar); + Tcl_DStringAppendElement(dsPtr, buf); + } + } + if (((flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { + Tcl_DStringEndSublist(dsPtr); + } + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || + ((len > 1) && (optionName[1] == 't') && + (strncmp(optionName, "-translation", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-translation"); + } + if (((flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { + Tcl_DStringStartSublist(dsPtr); + } + if (flags & TCL_READABLE) { + if (chanPtr->inputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_DStringAppendElement(dsPtr, "auto"); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CR) { + Tcl_DStringAppendElement(dsPtr, "cr"); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_DStringAppendElement(dsPtr, "crlf"); + } else { + Tcl_DStringAppendElement(dsPtr, "lf"); + } + } + if (flags & TCL_WRITABLE) { + if (chanPtr->outputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_DStringAppendElement(dsPtr, "auto"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CR) { + Tcl_DStringAppendElement(dsPtr, "cr"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_DStringAppendElement(dsPtr, "crlf"); + } else { + Tcl_DStringAppendElement(dsPtr, "lf"); + } + } + if (((flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { + Tcl_DStringEndSublist(dsPtr); + } + if (len > 0) { + return TCL_OK; + } + } + if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) { + /* + * let the driver specific handle additional options + * and result code and message. + */ + + return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData, + interp, optionName, dsPtr); + } else { + /* + * no driver specific options case. + */ + + if (len == 0) { + return TCL_OK; + } + return Tcl_BadChannelOption(interp, optionName, NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetChannelOption -- + * + * Sets an option on a channel. + * + * Results: + * A standard Tcl result. Also sets interp->result on error if + * interp is not NULL. + * + * Side effects: + * May modify an option on a device. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetChannelOption(interp, chan, optionName, newValue) + Tcl_Interp *interp; /* For error reporting - can be NULL. */ + Tcl_Channel chan; /* Channel on which to set mode. */ + char *optionName; /* Which option to set? */ + char *newValue; /* New value for option. */ +{ + int newMode; /* New (numeric) mode to sert. */ + Channel *chanPtr; /* The real IO channel. */ + size_t len; /* Length of optionName string. */ + int argc; + char **argv; + + chanPtr = (Channel *) chan; + + /* + * If the channel is in the middle of a background copy, fail. + */ + + if (chanPtr->csPtr) { + if (interp) { + Tcl_AppendResult(interp, + "unable to set channel options: background copy in progress", + (char *) NULL); + } + return TCL_ERROR; + } + + + /* + * Disallow options on dead channels -- channels that have been closed but + * not yet been deallocated. Such channels can be found if the exit + * handler for channel cleanup has run but the channel is still + * registered in an interpreter. + */ + + if (CheckForDeadChannel(NULL,chanPtr)) return TCL_ERROR; + + len = strlen(optionName); + + if ((len > 2) && (optionName[1] == 'b') && + (strncmp(optionName, "-blocking", len) == 0)) { + if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newMode) { + newMode = TCL_MODE_BLOCKING; + } else { + newMode = TCL_MODE_NONBLOCKING; + } + return SetBlockMode(interp, chanPtr, newMode); + } + + if ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffering", len) == 0)) { + len = strlen(newValue); + if ((newValue[0] == 'f') && (strncmp(newValue, "full", len) == 0)) { + chanPtr->flags &= + (~(CHANNEL_UNBUFFERED|CHANNEL_LINEBUFFERED)); + } else if ((newValue[0] == 'l') && + (strncmp(newValue, "line", len) == 0)) { + chanPtr->flags &= (~(CHANNEL_UNBUFFERED)); + chanPtr->flags |= CHANNEL_LINEBUFFERED; + } else if ((newValue[0] == 'n') && + (strncmp(newValue, "none", len) == 0)) { + chanPtr->flags &= (~(CHANNEL_LINEBUFFERED)); + chanPtr->flags |= CHANNEL_UNBUFFERED; + } else { + if (interp) { + Tcl_AppendResult(interp, "bad value for -buffering: ", + "must be one of full, line, or none", + (char *) NULL); + return TCL_ERROR; + } + } + return TCL_OK; + } + + if ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffersize", len) == 0)) { + chanPtr->bufSize = atoi(newValue); + if ((chanPtr->bufSize < 10) || (chanPtr->bufSize > (1024 * 1024))) { + chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; + } + return TCL_OK; + } + + if ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-eofchar", len) == 0)) { + if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } + if (argc == 0) { + chanPtr->inEofChar = 0; + chanPtr->outEofChar = 0; + } else if (argc == 1) { + if (chanPtr->flags & TCL_WRITABLE) { + chanPtr->outEofChar = (int) argv[0][0]; + } + if (chanPtr->flags & TCL_READABLE) { + chanPtr->inEofChar = (int) argv[0][0]; + } + } else if (argc != 2) { + if (interp) { + Tcl_AppendResult(interp, + "bad value for -eofchar: should be a list of one or", + " two elements", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } else { + if (chanPtr->flags & TCL_READABLE) { + chanPtr->inEofChar = (int) argv[0][0]; + } + if (chanPtr->flags & TCL_WRITABLE) { + chanPtr->outEofChar = (int) argv[1][0]; + } + } + if (argv != (char **) NULL) { + ckfree((char *) argv); + } + return TCL_OK; + } + + if ((len > 1) && (optionName[1] == 't') && + (strncmp(optionName, "-translation", len) == 0)) { + char *readMode, *writeMode; + + if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } + + if (argc == 1) { + readMode = (chanPtr->flags & TCL_READABLE) ? argv[0] : NULL; + writeMode = (chanPtr->flags & TCL_WRITABLE) ? argv[0] : NULL; + } else if (argc == 2) { + readMode = (chanPtr->flags & TCL_READABLE) ? argv[0] : NULL; + writeMode = (chanPtr->flags & TCL_WRITABLE) ? argv[1] : NULL; + } else { + if (interp) { + Tcl_AppendResult(interp, + "bad value for -translation: must be a one or two", + " element list", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + + if (readMode) { + if (*readMode == '\0') { + newMode = chanPtr->inputTranslation; + } else if (strcmp(readMode, "auto") == 0) { + newMode = TCL_TRANSLATE_AUTO; + } else if (strcmp(readMode, "binary") == 0) { + chanPtr->inEofChar = 0; + newMode = TCL_TRANSLATE_LF; + } else if (strcmp(readMode, "lf") == 0) { + newMode = TCL_TRANSLATE_LF; + } else if (strcmp(readMode, "cr") == 0) { + newMode = TCL_TRANSLATE_CR; + } else if (strcmp(readMode, "crlf") == 0) { + newMode = TCL_TRANSLATE_CRLF; + } else if (strcmp(readMode, "platform") == 0) { + newMode = TCL_PLATFORM_TRANSLATION; + } else { + if (interp) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + + /* + * Reset the EOL flags since we need to look at any buffered + * data to see if the new translation mode allows us to + * complete the line. + */ + + if (newMode != chanPtr->inputTranslation) { + chanPtr->inputTranslation = (Tcl_EolTranslation) newMode; + chanPtr->flags &= ~(INPUT_SAW_CR); + chanPtr->flags &= ~(CHANNEL_GETS_BLOCKED); + UpdateInterest(chanPtr); + } + } + if (writeMode) { + if (*writeMode == '\0') { + /* Do nothing. */ + } else if (strcmp(writeMode, "auto") == 0) { + /* + * This is a hack to get TCP sockets to produce output + * in CRLF mode if they are being set into AUTO mode. + * A better solution for achieving this effect will be + * coded later. + */ + + if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } + } else if (strcmp(writeMode, "binary") == 0) { + chanPtr->outEofChar = 0; + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(writeMode, "lf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(writeMode, "cr") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(writeMode, "crlf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(writeMode, "platform") == 0) { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + ckfree((char *) argv); + return TCL_OK; + } + + if (chanPtr->typePtr->setOptionProc != (Tcl_DriverSetOptionProc *) NULL) { + return (chanPtr->typePtr->setOptionProc) (chanPtr->instanceData, + interp, optionName, newValue); + } + + return Tcl_BadChannelOption(interp, optionName, (char *) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * CleanupChannelHandlers -- + * + * Removes channel handlers that refer to the supplied interpreter, + * so that if the actual channel is not closed now, these handlers + * will not run on subsequent events on the channel. This would be + * erroneous, because the interpreter no longer has a reference to + * this channel. + * + * Results: + * None. + * + * Side effects: + * Removes channel handlers. + * + *---------------------------------------------------------------------- + */ + +static void +CleanupChannelHandlers(interp, chanPtr) + Tcl_Interp *interp; + Channel *chanPtr; +{ + EventScriptRecord *sPtr, *prevPtr, *nextPtr; + + /* + * Remove fileevent records on this channel that refer to the + * given interpreter. + */ + + for (sPtr = chanPtr->scriptRecordPtr, + prevPtr = (EventScriptRecord *) NULL; + sPtr != (EventScriptRecord *) NULL; + sPtr = nextPtr) { + nextPtr = sPtr->nextPtr; + if (sPtr->interp == interp) { + if (prevPtr == (EventScriptRecord *) NULL) { + chanPtr->scriptRecordPtr = nextPtr; + } else { + prevPtr->nextPtr = nextPtr; + } + + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) sPtr); + + ckfree(sPtr->script); + ckfree((char *) sPtr); + } else { + prevPtr = sPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NotifyChannel -- + * + * This procedure is called by a channel driver when a driver + * detects an event on a channel. This procedure is responsible + * for actually handling the event by invoking any channel + * handler callbacks. + * + * Results: + * None. + * + * Side effects: + * Whatever the channel handler callback procedure does. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_NotifyChannel(channel, mask) + Tcl_Channel channel; /* Channel that detected an event. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which events were detected. */ +{ + Channel *chanPtr = (Channel *) channel; + ChannelHandler *chPtr; + NextChannelHandler nh; + + /* + * Preserve the channel struct in case the script closes it. + */ + + Tcl_Preserve((ClientData) channel); + + /* + * If we are flushing in the background, be sure to call FlushChannel + * for writable events. Note that we have to discard the writable + * event so we don't call any write handlers before the flush is + * complete. + */ + + if ((chanPtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) { + FlushChannel(NULL, chanPtr, 1); + mask &= ~TCL_WRITABLE; + } + + /* + * Add this invocation to the list of recursive invocations of + * ChannelHandlerEventProc. + */ + + nh.nextHandlerPtr = (ChannelHandler *) NULL; + nh.nestedHandlerPtr = nestedHandlerPtr; + nestedHandlerPtr = &nh; + + for (chPtr = chanPtr->chPtr; chPtr != (ChannelHandler *) NULL; ) { + + /* + * If this channel handler is interested in any of the events that + * have occurred on the channel, invoke its procedure. + */ + + if ((chPtr->mask & mask) != 0) { + nh.nextHandlerPtr = chPtr->nextPtr; + (*(chPtr->proc))(chPtr->clientData, mask); + chPtr = nh.nextHandlerPtr; + } else { + chPtr = chPtr->nextPtr; + } + } + + /* + * Update the notifier interest, since it may have changed after + * invoking event handlers. + */ + + if (chanPtr->typePtr != NULL) { + UpdateInterest(chanPtr); + } + + Tcl_Release((ClientData) channel); + + nestedHandlerPtr = nh.nestedHandlerPtr; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateInterest -- + * + * Arrange for the notifier to call us back at appropriate times + * based on the current state of the channel. + * + * Results: + * None. + * + * Side effects: + * May schedule a timer or driver handler. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateInterest(chanPtr) + Channel *chanPtr; /* Channel to update. */ +{ + int mask = chanPtr->interestMask; + + /* + * If there are flushed buffers waiting to be written, then + * we need to watch for the channel to become writable. + */ + + if (chanPtr->flags & BG_FLUSH_SCHEDULED) { + mask |= TCL_WRITABLE; + } + + /* + * If there is data in the input queue, and we aren't blocked waiting for + * an EOL, then we need to schedule a timer so we don't block in the + * notifier. Also, cancel the read interest so we don't get duplicate + * events. + */ + + if (mask & TCL_READABLE) { + if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED) + && (chanPtr->inQueueHead != (ChannelBuffer *) NULL) + && (chanPtr->inQueueHead->nextRemoved < + chanPtr->inQueueHead->nextAdded)) { + mask &= ~TCL_READABLE; + if (!chanPtr->timer) { + chanPtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, + (ClientData) chanPtr); + } + } + } + (chanPtr->typePtr->watchProc)(chanPtr->instanceData, mask); +} + +/* + *---------------------------------------------------------------------- + * + * ChannelTimerProc -- + * + * Timer handler scheduled by UpdateInterest to monitor the + * channel buffers until they are empty. + * + * Results: + * None. + * + * Side effects: + * May invoke channel handlers. + * + *---------------------------------------------------------------------- + */ + +static void +ChannelTimerProc(clientData) + ClientData clientData; +{ + Channel *chanPtr = (Channel *) clientData; + + if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED) + && (chanPtr->interestMask & TCL_READABLE) + && (chanPtr->inQueueHead != (ChannelBuffer *) NULL) + && (chanPtr->inQueueHead->nextRemoved < + chanPtr->inQueueHead->nextAdded)) { + /* + * Restart the timer in case a channel handler reenters the + * event loop before UpdateInterest gets called by Tcl_NotifyChannel. + */ + + chanPtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, + (ClientData) chanPtr); + Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE); + + } else { + chanPtr->timer = NULL; + UpdateInterest(chanPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateChannelHandler -- + * + * Arrange for a given procedure to be invoked whenever the + * channel indicated by the chanPtr arg becomes readable or + * writable. + * + * Results: + * None. + * + * Side effects: + * From now on, whenever the I/O channel given by chanPtr becomes + * ready in the way indicated by mask, proc will be invoked. + * See the manual entry for details on the calling sequence + * to proc. If there is already an event handler for chan, proc + * and clientData, then the mask will be updated. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateChannelHandler(chan, mask, proc, clientData) + Tcl_Channel chan; /* The channel to create the handler for. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions under which + * proc should be called. Use 0 to + * disable a registered handler. */ + Tcl_ChannelProc *proc; /* Procedure to call for each + * selected event. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + ChannelHandler *chPtr; + Channel *chanPtr; + + chanPtr = (Channel *) chan; + + /* + * Check whether this channel handler is not already registered. If + * it is not, create a new record, else reuse existing record (smash + * current values). + */ + + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) && + (chPtr->clientData == clientData)) { + break; + } + } + if (chPtr == (ChannelHandler *) NULL) { + chPtr = (ChannelHandler *) ckalloc((unsigned) sizeof(ChannelHandler)); + chPtr->mask = 0; + chPtr->proc = proc; + chPtr->clientData = clientData; + chPtr->chanPtr = chanPtr; + chPtr->nextPtr = chanPtr->chPtr; + chanPtr->chPtr = chPtr; + } + + /* + * The remainder of the initialization below is done regardless of + * whether or not this is a new record or a modification of an old + * one. + */ + + chPtr->mask = mask; + + /* + * Recompute the interest mask for the channel - this call may actually + * be disabling an existing handler. + */ + + chanPtr->interestMask = 0; + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + chanPtr->interestMask |= chPtr->mask; + } + + UpdateInterest(chanPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteChannelHandler -- + * + * Cancel a previously arranged callback arrangement for an IO + * channel. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered for this chan, proc and + * clientData , it is removed and the callback will no longer be called + * when the channel becomes ready for IO. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteChannelHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to remove the + * callback. */ + Tcl_ChannelProc *proc; /* The procedure in the callback to delete. */ + ClientData clientData; /* The client data in the callback + * to delete. */ + +{ + ChannelHandler *chPtr, *prevChPtr; + Channel *chanPtr; + NextChannelHandler *nhPtr; + + chanPtr = (Channel *) chan; + + /* + * Find the entry and the previous one in the list. + */ + + for (prevChPtr = (ChannelHandler *) NULL, chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + if ((chPtr->chanPtr == chanPtr) && (chPtr->clientData == clientData) + && (chPtr->proc == proc)) { + break; + } + prevChPtr = chPtr; + } + + /* + * If not found, return without doing anything. + */ + + if (chPtr == (ChannelHandler *) NULL) { + return; + } + + /* + * If ChannelHandlerEventProc is about to process this handler, tell it to + * process the next one instead - we are going to delete *this* one. + */ + + for (nhPtr = nestedHandlerPtr; + nhPtr != (NextChannelHandler *) NULL; + nhPtr = nhPtr->nestedHandlerPtr) { + if (nhPtr->nextHandlerPtr == chPtr) { + nhPtr->nextHandlerPtr = chPtr->nextPtr; + } + } + + /* + * Splice it out of the list of channel handlers. + */ + + if (prevChPtr == (ChannelHandler *) NULL) { + chanPtr->chPtr = chPtr->nextPtr; + } else { + prevChPtr->nextPtr = chPtr->nextPtr; + } + ckfree((char *) chPtr); + + /* + * Recompute the interest list for the channel, so that infinite loops + * will not result if Tcl_DeleteChanelHandler is called inside an event. + */ + + chanPtr->interestMask = 0; + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + chanPtr->interestMask |= chPtr->mask; + } + + UpdateInterest(chanPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteScriptRecord -- + * + * Delete a script record for this combination of channel, interp + * and mask. + * + * Results: + * None. + * + * Side effects: + * Deletes a script record and cancels a channel event handler. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteScriptRecord(interp, chanPtr, mask) + Tcl_Interp *interp; /* Interpreter in which script was to be + * executed. */ + Channel *chanPtr; /* The channel for which to delete the + * script record (if any). */ + int mask; /* Events in mask must exactly match mask + * of script to delete. */ +{ + EventScriptRecord *esPtr, *prevEsPtr; + + for (esPtr = chanPtr->scriptRecordPtr, + prevEsPtr = (EventScriptRecord *) NULL; + esPtr != (EventScriptRecord *) NULL; + prevEsPtr = esPtr, esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + if (esPtr == chanPtr->scriptRecordPtr) { + chanPtr->scriptRecordPtr = esPtr->nextPtr; + } else { + prevEsPtr->nextPtr = esPtr->nextPtr; + } + + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + + ckfree(esPtr->script); + ckfree((char *) esPtr); + + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CreateScriptRecord -- + * + * Creates a record to store a script to be executed when a specific + * event fires on a specific channel. + * + * Results: + * None. + * + * Side effects: + * Causes the script to be stored for later execution. + * + *---------------------------------------------------------------------- + */ + +static void +CreateScriptRecord(interp, chanPtr, mask, script) + Tcl_Interp *interp; /* Interpreter in which to execute + * the stored script. */ + Channel *chanPtr; /* Channel for which script is to + * be stored. */ + int mask; /* Set of events for which script + * will be invoked. */ + char *script; /* A copy of this script is stored + * in the newly created record. */ +{ + EventScriptRecord *esPtr; + + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + ckfree(esPtr->script); + esPtr->script = (char *) NULL; + break; + } + } + if (esPtr == (EventScriptRecord *) NULL) { + esPtr = (EventScriptRecord *) ckalloc((unsigned) + sizeof(EventScriptRecord)); + Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, + ChannelEventScriptInvoker, (ClientData) esPtr); + esPtr->nextPtr = chanPtr->scriptRecordPtr; + chanPtr->scriptRecordPtr = esPtr; + } + esPtr->chanPtr = chanPtr; + esPtr->interp = interp; + esPtr->mask = mask; + esPtr->script = ckalloc((unsigned) (strlen(script) + 1)); + strcpy(esPtr->script, script); +} + +/* + *---------------------------------------------------------------------- + * + * ChannelEventScriptInvoker -- + * + * Invokes a script scheduled by "fileevent" for when the channel + * becomes ready for IO. This function is invoked by the channel + * handler which was created by the Tcl "fileevent" command. + * + * Results: + * None. + * + * Side effects: + * Whatever the script does. + * + *---------------------------------------------------------------------- + */ + +static void +ChannelEventScriptInvoker(clientData, mask) + ClientData clientData; /* The script+interp record. */ + int mask; /* Not used. */ +{ + Tcl_Interp *interp; /* Interpreter in which to eval the script. */ + Channel *chanPtr; /* The channel for which this handler is + * registered. */ + char *script; /* Script to eval. */ + EventScriptRecord *esPtr; /* The event script + interpreter to eval it + * in. */ + int result; /* Result of call to eval script. */ + + esPtr = (EventScriptRecord *) clientData; + + chanPtr = esPtr->chanPtr; + mask = esPtr->mask; + interp = esPtr->interp; + script = esPtr->script; + + /* + * We must preserve the interpreter so we can report errors on it + * later. Note that we do not need to preserve the channel because + * that is done by Tcl_NotifyChannel before calling channel handlers. + */ + + Tcl_Preserve((ClientData) interp); + result = Tcl_GlobalEval(interp, script); + + /* + * On error, cause a background error and remove the channel handler + * and the script record. + * + * NOTE: Must delete channel handler before causing the background error + * because the background error may want to reinstall the handler. + */ + + if (result != TCL_OK) { + if (chanPtr->typePtr != NULL) { + DeleteScriptRecord(interp, chanPtr, mask); + } + Tcl_BackgroundError(interp); + } + Tcl_Release((ClientData) interp); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FileEventCmd -- + * + * This procedure implements the "fileevent" Tcl command. See the + * user documentation for details on what it does. This command is + * based on the Tk command "fileevent" which in turn is based on work + * contributed by Mark Diekhans. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May create a channel handler for the specified channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FileEventCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter in which the channel + * for which to create the handler + * is found. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Channel *chanPtr; /* The channel to create + * the handler for. */ + Tcl_Channel chan; /* The opaque type for the channel. */ + int c; /* First char of mode argument. */ + int mask; /* Mask for events of interest. */ + size_t length; /* Length of mode argument. */ + + /* + * Parse arguments. + */ + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: must be \"", argv[0], + " channelId event ?script?", (char *) NULL); + return TCL_ERROR; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((c == 'r') && (strncmp(argv[2], "readable", length) == 0)) { + mask = TCL_READABLE; + } else if ((c == 'w') && (strncmp(argv[2], "writable", length) == 0)) { + mask = TCL_WRITABLE; + } else { + Tcl_AppendResult(interp, "bad event name \"", argv[2], + "\": must be readable or writable", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + chanPtr = (Channel *) chan; + if ((chanPtr->flags & mask) == 0) { + Tcl_AppendResult(interp, "channel is not ", + (mask == TCL_READABLE) ? "readable" : "writable", + (char *) NULL); + return TCL_ERROR; + } + + /* + * If we are supposed to return the script, do so. + */ + + if (argc == 3) { + EventScriptRecord *esPtr; + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + Tcl_SetResult(interp, esPtr->script, TCL_STATIC); + break; + } + } + return TCL_OK; + } + + /* + * If we are supposed to delete a stored script, do so. + */ + + if (argv[3][0] == 0) { + DeleteScriptRecord(interp, chanPtr, mask); + return TCL_OK; + } + + /* + * Make the script record that will link between the event and the + * script to invoke. This also creates a channel event handler which + * will evaluate the script in the supplied interpreter. + */ + + CreateScriptRecord(interp, chanPtr, mask, argv[3]); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclTestChannelCmd -- + * + * Implements the Tcl "testchannel" debugging command and its + * subcommands. This is part of the testing environment but must be + * in this file instead of tclTest.c because it needs access to the + * fields of struct Channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclTestChannelCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter for result. */ + int argc; /* Count of additional args. */ + char **argv; /* Additional arg strings. */ +{ + char *cmdName; /* Sub command. */ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* The actual channel. */ + Tcl_Channel chan; /* The opaque type. */ + size_t len; /* Length of subcommand string. */ + int IOQueued; /* How much IO is queued inside channel? */ + ChannelBuffer *bufPtr; /* For iterating over queued IO. */ + char buf[128]; /* For sprintf. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " subcommand ?additional args..?\"", (char *) NULL); + return TCL_ERROR; + } + cmdName = argv[1]; + len = strlen(cmdName); + + chanPtr = (Channel *) NULL; + if (argc > 2) { + chan = Tcl_GetChannel(interp, argv[2], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + chanPtr = (Channel *) chan; + } + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " info channelName\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, argv[2]); + Tcl_AppendElement(interp, chanPtr->typePtr->typeName); + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, "read"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, "write"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + Tcl_AppendElement(interp, "nonblocking"); + } else { + Tcl_AppendElement(interp, "blocking"); + } + if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + Tcl_AppendElement(interp, "line"); + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + Tcl_AppendElement(interp, "none"); + } else { + Tcl_AppendElement(interp, "full"); + } + if (chanPtr->flags & BG_FLUSH_SCHEDULED) { + Tcl_AppendElement(interp, "async_flush"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_EOF) { + Tcl_AppendElement(interp, "eof"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + Tcl_AppendElement(interp, "blocked"); + } else { + Tcl_AppendElement(interp, "unblocked"); + } + if (chanPtr->inputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_AppendElement(interp, "auto"); + if (chanPtr->flags & INPUT_SAW_CR) { + Tcl_AppendElement(interp, "saw_cr"); + } else { + Tcl_AppendElement(interp, ""); + } + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_LF) { + Tcl_AppendElement(interp, "lf"); + Tcl_AppendElement(interp, ""); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CR) { + Tcl_AppendElement(interp, "cr"); + Tcl_AppendElement(interp, ""); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_AppendElement(interp, "crlf"); + if (chanPtr->flags & INPUT_SAW_CR) { + Tcl_AppendElement(interp, "queued_cr"); + } else { + Tcl_AppendElement(interp, ""); + } + } + if (chanPtr->outputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_AppendElement(interp, "auto"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_LF) { + Tcl_AppendElement(interp, "lf"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CR) { + Tcl_AppendElement(interp, "cr"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_AppendElement(interp, "crlf"); + } + for (IOQueued = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; + } + TclFormatInt(buf, IOQueued); + Tcl_AppendElement(interp, buf); + + IOQueued = 0; + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + IOQueued = chanPtr->curOutPtr->nextAdded - + chanPtr->curOutPtr->nextRemoved; + } + for (bufPtr = chanPtr->outQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + TclFormatInt(buf, IOQueued); + Tcl_AppendElement(interp, buf); + + TclFormatInt(buf, Tcl_Tell((Tcl_Channel) chanPtr)); + Tcl_AppendElement(interp, buf); + + TclFormatInt(buf, chanPtr->refCount); + Tcl_AppendElement(interp, buf); + + return TCL_OK; + } + + if ((cmdName[0] == 'i') && + (strncmp(cmdName, "inputbuffered", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + for (IOQueued = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, "read"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, "write"); + } else { + Tcl_AppendElement(interp, ""); + } + return TCL_OK; + } + + if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, chanPtr->channelName, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + return TCL_OK; + } + + if ((cmdName[0] == 'o') && + (strncmp(cmdName, "outputbuffered", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + IOQueued = 0; + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + IOQueued = chanPtr->curOutPtr->nextAdded - + chanPtr->curOutPtr->nextRemoved; + } + for (bufPtr = chanPtr->outQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'q') && + (strncmp(cmdName, "queuedcr", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + Tcl_AppendResult(interp, + (chanPtr->flags & INPUT_SAW_CR) ? "1" : "0", + (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + } + return TCL_OK; + } + + if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + sprintf(buf, "%d", chanPtr->refCount); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, chanPtr->typePtr->typeName, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + } + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ", + "info, open, readable, or writable", + (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclTestChannelEventCmd -- + * + * This procedure implements the "testchannelevent" command. It is + * used to test the Tcl channel event mechanism. It is present in + * this file instead of tclTest.c because it needs access to the + * internal structure of the channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes and returns channel event handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclTestChannelEventCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Channel *chanPtr; + EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr; + char *cmd; + int index, i, mask, len; + + if ((argc < 3) || (argc > 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName cmd ?arg1? ?arg2?\"", (char *) NULL); + return TCL_ERROR; + } + chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL); + if (chanPtr == (Channel *) NULL) { + return TCL_ERROR; + } + cmd = argv[2]; + len = strlen(cmd); + if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName add eventSpec script\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[3], "readable") == 0) { + mask = TCL_READABLE; + } else if (strcmp(argv[3], "writable") == 0) { + mask = TCL_WRITABLE; + } else if (strcmp(argv[3], "none") == 0) { + mask = 0; + } else { + Tcl_AppendResult(interp, "bad event name \"", argv[3], + "\": must be readable, writable, or none", (char *) NULL); + return TCL_ERROR; + } + + esPtr = (EventScriptRecord *) ckalloc((unsigned) + sizeof(EventScriptRecord)); + esPtr->nextPtr = chanPtr->scriptRecordPtr; + chanPtr->scriptRecordPtr = esPtr; + + esPtr->chanPtr = chanPtr; + esPtr->interp = interp; + esPtr->mask = mask; + esPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); + strcpy(esPtr->script, argv[4]); + + Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, + ChannelEventScriptInvoker, (ClientData) esPtr); + + return TCL_OK; + } + + if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName delete index\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { + return TCL_ERROR; + } + if (index < 0) { + Tcl_AppendResult(interp, "bad event index: ", argv[3], + ": must be nonnegative", (char *) NULL); + return TCL_ERROR; + } + for (i = 0, esPtr = chanPtr->scriptRecordPtr; + (i < index) && (esPtr != (EventScriptRecord *) NULL); + i++, esPtr = esPtr->nextPtr) { + /* Empty loop body. */ + } + if (esPtr == (EventScriptRecord *) NULL) { + Tcl_AppendResult(interp, "bad event index ", argv[3], + ": out of range", (char *) NULL); + return TCL_ERROR; + } + if (esPtr == chanPtr->scriptRecordPtr) { + chanPtr->scriptRecordPtr = esPtr->nextPtr; + } else { + for (prevEsPtr = chanPtr->scriptRecordPtr; + (prevEsPtr != (EventScriptRecord *) NULL) && + (prevEsPtr->nextPtr != esPtr); + prevEsPtr = prevEsPtr->nextPtr) { + /* Empty loop body. */ + } + if (prevEsPtr == (EventScriptRecord *) NULL) { + panic("TclTestChannelEventCmd: damaged event script list"); + } + prevEsPtr->nextPtr = esPtr->nextPtr; + } + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + ckfree(esPtr->script); + ckfree((char *) esPtr); + + return TCL_OK; + } + + if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName list\"", (char *) NULL); + return TCL_ERROR; + } + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + char *event; + if (esPtr->mask) { + event = ((esPtr->mask == TCL_READABLE) + ? "readable" : "writable"); + } else { + event = "none"; + } + Tcl_AppendElement(interp, event); + Tcl_AppendElement(interp, esPtr->script); + } + return TCL_OK; + } + + if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName removeall\"", (char *) NULL); + return TCL_ERROR; + } + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = nextEsPtr) { + nextEsPtr = esPtr->nextPtr; + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + ckfree(esPtr->script); + ckfree((char *) esPtr); + } + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + return TCL_OK; + } + + if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName delete index event\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { + return TCL_ERROR; + } + if (index < 0) { + Tcl_AppendResult(interp, "bad event index: ", argv[3], + ": must be nonnegative", (char *) NULL); + return TCL_ERROR; + } + for (i = 0, esPtr = chanPtr->scriptRecordPtr; + (i < index) && (esPtr != (EventScriptRecord *) NULL); + i++, esPtr = esPtr->nextPtr) { + /* Empty loop body. */ + } + if (esPtr == (EventScriptRecord *) NULL) { + Tcl_AppendResult(interp, "bad event index ", argv[3], + ": out of range", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[4], "readable") == 0) { + mask = TCL_READABLE; + } else if (strcmp(argv[4], "writable") == 0) { + mask = TCL_WRITABLE; + } else if (strcmp(argv[4], "none") == 0) { + mask = 0; + } else { + Tcl_AppendResult(interp, "bad event name \"", argv[4], + "\": must be readable, writable, or none", (char *) NULL); + return TCL_ERROR; + } + esPtr->mask = mask; + Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, + ChannelEventScriptInvoker, (ClientData) esPtr); + return TCL_OK; + } + Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ", + "add, delete, list, set, or removeall", (char *) NULL); + return TCL_ERROR; + +} + +/* + *---------------------------------------------------------------------- + * + * TclCopyChannel -- + * + * This routine copies data from one channel to another, either + * synchronously or asynchronously. If a command script is + * supplied, the operation runs in the background. The script + * is invoked when the copy completes. Otherwise the function + * waits until the copy is completed before returning. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May schedule a background copy operation that causes both + * channels to be marked busy. + * + *---------------------------------------------------------------------- + */ + +int +TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Channel inChan; /* Channel to read from. */ + Tcl_Channel outChan; /* Channel to write to. */ + int toRead; /* Amount of data to copy, or -1 for all. */ + Tcl_Obj *cmdPtr; /* Pointer to script to execute or NULL. */ +{ + Channel *inPtr = (Channel *) inChan; + Channel *outPtr = (Channel *) outChan; + int readFlags, writeFlags; + CopyState *csPtr; + int nonBlocking = (cmdPtr) ? CHANNEL_NONBLOCKING : 0; + + if (inPtr->csPtr) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + Tcl_GetChannelName(inChan), "\" is busy", NULL); + return TCL_ERROR; + } + if (outPtr->csPtr) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + Tcl_GetChannelName(outChan), "\" is busy", NULL); + return TCL_ERROR; + } + + readFlags = inPtr->flags; + writeFlags = outPtr->flags; + + /* + * Set up the blocking mode appropriately. Background copies need + * non-blocking channels. Foreground copies need blocking channels. + * If there is an error, restore the old blocking mode. + */ + + if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) { + if (SetBlockMode(interp, inPtr, + nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING) + != TCL_OK) { + return TCL_ERROR; + } + } + if (inPtr != outPtr) { + if (nonBlocking != (writeFlags & CHANNEL_NONBLOCKING)) { + if (SetBlockMode(NULL, outPtr, + nonBlocking ? TCL_MODE_BLOCKING : TCL_MODE_NONBLOCKING) + != TCL_OK) { + if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) { + SetBlockMode(NULL, inPtr, + (readFlags & CHANNEL_NONBLOCKING) + ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); + return TCL_ERROR; + } + } + } + } + + /* + * Make sure the output side is unbuffered. + */ + + outPtr->flags = (outPtr->flags & ~(CHANNEL_LINEBUFFERED)) + | CHANNEL_UNBUFFERED; + + /* + * Allocate a new CopyState to maintain info about the current copy in + * progress. This structure will be deallocated when the copy is + * completed. + */ + + csPtr = (CopyState*) ckalloc(sizeof(CopyState) + inPtr->bufSize); + csPtr->bufSize = inPtr->bufSize; + csPtr->readPtr = inPtr; + csPtr->writePtr = outPtr; + csPtr->readFlags = readFlags; + csPtr->writeFlags = writeFlags; + csPtr->toRead = toRead; + csPtr->total = 0; + csPtr->interp = interp; + if (cmdPtr) { + Tcl_IncrRefCount(cmdPtr); + } + csPtr->cmdPtr = cmdPtr; + inPtr->csPtr = csPtr; + outPtr->csPtr = csPtr; + + /* + * Start copying data between the channels. + */ + + return CopyData(csPtr, 0); +} + +/* + *---------------------------------------------------------------------- + * + * CopyData -- + * + * This function implements the lowest level of the copying + * mechanism for TclCopyChannel. + * + * Results: + * Returns TCL_OK on success, else TCL_ERROR. + * + * Side effects: + * Moves data between channels, may create channel handlers. + * + *---------------------------------------------------------------------- + */ + +static int +CopyData(csPtr, mask) + CopyState *csPtr; /* State of copy operation. */ + int mask; /* Current channel event flags. */ +{ + Tcl_Interp *interp; + Tcl_Obj *cmdPtr, *errObj = NULL; + Tcl_Channel inChan, outChan; + int result = TCL_OK; + int size; + int total; + + inChan = (Tcl_Channel)csPtr->readPtr; + outChan = (Tcl_Channel)csPtr->writePtr; + interp = csPtr->interp; + cmdPtr = csPtr->cmdPtr; + + /* + * Copy the data the slow way, using the translation mechanism. + */ + + while (csPtr->toRead != 0) { + + /* + * Check for unreported background errors. + */ + + if (csPtr->readPtr->unreportedError != 0) { + Tcl_SetErrno(csPtr->readPtr->unreportedError); + csPtr->readPtr->unreportedError = 0; + goto readError; + } + if (csPtr->writePtr->unreportedError != 0) { + Tcl_SetErrno(csPtr->writePtr->unreportedError); + csPtr->writePtr->unreportedError = 0; + goto writeError; + } + + /* + * Read up to bufSize bytes. + */ + + if ((csPtr->toRead == -1) + || (csPtr->toRead > csPtr->bufSize)) { + size = csPtr->bufSize; + } else { + size = csPtr->toRead; + } + size = DoRead(csPtr->readPtr, csPtr->buffer, size); + + if (size < 0) { + readError: + errObj = Tcl_NewObj(); + Tcl_AppendStringsToObj(errObj, "error reading \"", + Tcl_GetChannelName(inChan), "\": ", + Tcl_PosixError(interp), (char *) NULL); + break; + } else if (size == 0) { + /* + * We had an underflow on the read side. If we are at EOF, + * then the copying is done, otherwise set up a channel + * handler to detect when the channel becomes readable again. + */ + + if (Tcl_Eof(inChan)) { + break; + } else if (!(mask & TCL_READABLE)) { + if (mask & TCL_WRITABLE) { + Tcl_DeleteChannelHandler(outChan, CopyEventProc, + (ClientData) csPtr); + } + Tcl_CreateChannelHandler(inChan, TCL_READABLE, + CopyEventProc, (ClientData) csPtr); + } + return TCL_OK; + } + + /* + * Now write the buffer out. + */ + + size = DoWrite(csPtr->writePtr, csPtr->buffer, size); + if (size < 0) { + writeError: + errObj = Tcl_NewObj(); + Tcl_AppendStringsToObj(errObj, "error writing \"", + Tcl_GetChannelName(outChan), "\": ", + Tcl_PosixError(interp), (char *) NULL); + break; + } + + /* + * Check to see if the write is happening in the background. If so, + * stop copying and wait for the channel to become writable again. + */ + + if (csPtr->writePtr->flags & BG_FLUSH_SCHEDULED) { + if (!(mask & TCL_WRITABLE)) { + if (mask & TCL_READABLE) { + Tcl_DeleteChannelHandler(outChan, CopyEventProc, + (ClientData) csPtr); + } + Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, + CopyEventProc, (ClientData) csPtr); + } + return TCL_OK; + } + + /* + * Update the current byte count if we care. + */ + + if (csPtr->toRead != -1) { + csPtr->toRead -= size; + } + csPtr->total += size; + + /* + * For background copies, we only do one buffer per invocation so + * we don't starve the rest of the system. + */ + + if (cmdPtr) { + /* + * The first time we enter this code, there won't be a + * channel handler established yet, so do it here. + */ + + if (mask == 0) { + Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, + CopyEventProc, (ClientData) csPtr); + } + return TCL_OK; + } + } + + /* + * Make the callback or return the number of bytes transferred. + * The local total is used because StopCopy frees csPtr. + */ + + total = csPtr->total; + if (cmdPtr) { + /* + * Get a private copy of the command so we can mutate it + * by adding arguments. Note that StopCopy frees our saved + * reference to the original command obj. + */ + + cmdPtr = Tcl_DuplicateObj(cmdPtr); + Tcl_IncrRefCount(cmdPtr); + StopCopy(csPtr); + Tcl_Preserve((ClientData) interp); + + Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(total)); + if (errObj) { + Tcl_ListObjAppendElement(interp, cmdPtr, errObj); + } + if (Tcl_GlobalEvalObj(interp, cmdPtr) != TCL_OK) { + Tcl_BackgroundError(interp); + result = TCL_ERROR; + } + Tcl_DecrRefCount(cmdPtr); + Tcl_Release((ClientData) interp); + } else { + StopCopy(csPtr); + if (errObj) { + Tcl_SetObjResult(interp, errObj); + result = TCL_ERROR; + } else { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), total); + } + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CopyEventProc -- + * + * This routine is invoked as a channel event handler for + * the background copy operation. It is just a trivial wrapper + * around the CopyData routine. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +CopyEventProc(clientData, mask) + ClientData clientData; + int mask; +{ + (void) CopyData((CopyState *)clientData, mask); +} + +/* + *---------------------------------------------------------------------- + * + * StopCopy -- + * + * This routine halts a copy that is in progress. + * + * Results: + * None. + * + * Side effects: + * Removes any pending channel handlers and restores the blocking + * and buffering modes of the channels. The CopyState is freed. + * + *---------------------------------------------------------------------- + */ + +static void +StopCopy(csPtr) + CopyState *csPtr; /* State for bg copy to stop . */ +{ + int nonBlocking; + + if (!csPtr) { + return; + } + + /* + * Restore the old blocking mode and output buffering mode. + */ + + nonBlocking = (csPtr->readFlags & CHANNEL_NONBLOCKING); + if (nonBlocking != (csPtr->readPtr->flags & CHANNEL_NONBLOCKING)) { + SetBlockMode(NULL, csPtr->readPtr, + nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); + } + if (csPtr->writePtr != csPtr->writePtr) { + if (nonBlocking != (csPtr->writePtr->flags & CHANNEL_NONBLOCKING)) { + SetBlockMode(NULL, csPtr->writePtr, + nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); + } + } + csPtr->writePtr->flags &= ~(CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); + csPtr->writePtr->flags |= + csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); + + + if (csPtr->cmdPtr) { + Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->readPtr, CopyEventProc, + (ClientData)csPtr); + if (csPtr->readPtr != csPtr->writePtr) { + Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->writePtr, + CopyEventProc, (ClientData)csPtr); + } + Tcl_DecrRefCount(csPtr->cmdPtr); + } + csPtr->readPtr->csPtr = NULL; + csPtr->writePtr->csPtr = NULL; + ckfree((char*) csPtr); +} diff --git a/tcl/generic/tclIOCmd.c b/tcl/generic/tclIOCmd.c new file mode 100644 index 00000000000..5e6eb3de36d --- /dev/null +++ b/tcl/generic/tclIOCmd.c @@ -0,0 +1,1571 @@ +/* + * tclIOCmd.c -- + * + * Contains the definitions of most of the Tcl commands relating to IO. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Return at most this number of bytes in one call to Tcl_Read: + */ + +#define TCL_READ_CHUNK_SIZE 4096 + +/* + * Callback structure for accept callback in a TCP server. + */ + +typedef struct AcceptCallback { + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* Interpreter in which to run it. */ +} AcceptCallback; + +/* + * Static functions for this file: + */ + +static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData, + Tcl_Channel chan, char *address, int port)); +static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp, + AcceptCallback *acceptCallbackPtr)); +static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData)); +static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( + Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_PutsObjCmd -- + * + * This procedure is invoked to process the "puts" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Produces output on a channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PutsObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to puts on. */ + int i; /* Counter. */ + int newline; /* Add a newline at end? */ + char *channelId; /* Name of channel for puts. */ + int result; /* Result of puts operation. */ + int mode; /* Mode in which channel is opened. */ + char *arg; + int length; + Tcl_Obj *resultPtr; + + i = 1; + newline = 1; + if ((objc >= 2) && (strcmp(Tcl_GetStringFromObj(objv[1], NULL), + "-nonewline") == 0)) { + newline = 0; + i++; + } + if ((i < (objc-3)) || (i >= objc)) { + Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); + return TCL_ERROR; + } + + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or documented. + */ + + resultPtr = Tcl_NewObj(); + if (i == (objc-3)) { + arg = Tcl_GetStringFromObj(objv[i+2], &length); + if (strncmp(arg, "nonewline", (size_t) length) != 0) { + Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg, + "\": should be \"nonewline\"", (char *) NULL); + Tcl_SetObjResult(interp, resultPtr); + return TCL_ERROR; + } + newline = 0; + } + if (i == (objc-1)) { + channelId = "stdout"; + } else { + channelId = Tcl_GetStringFromObj(objv[i], NULL); + i++; + } + chan = Tcl_GetChannel(interp, channelId, &mode); + if (chan == (Tcl_Channel) NULL) { + Tcl_DecrRefCount(resultPtr); + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendStringsToObj(resultPtr, "channel \"", channelId, + "\" wasn't opened for writing", (char *) NULL); + Tcl_SetObjResult(interp, resultPtr); + return TCL_ERROR; + } + + arg = Tcl_GetStringFromObj(objv[i], &length); + result = Tcl_Write(chan, arg, length); + if (result < 0) { + goto error; + } + if (newline != 0) { + result = Tcl_Write(chan, "\n", 1); + if (result < 0) { + goto error; + } + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +error: + Tcl_AppendStringsToObj(resultPtr, "error writing \"", + Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), + (char *) NULL); + Tcl_SetObjResult(interp, resultPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FlushObjCmd -- + * + * This procedure is called to process the Tcl "flush" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May cause output to appear on the specified channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FlushObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to flush on. */ + char *arg; + Tcl_Obj *resultPtr; + int mode; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + return TCL_ERROR; + } + arg = Tcl_GetStringFromObj(objv[1], NULL); + chan = Tcl_GetChannel(interp, arg, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + resultPtr = Tcl_GetObjResult(interp); + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendStringsToObj(resultPtr, "channel \"", + Tcl_GetStringFromObj(objv[1], NULL), + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + if (Tcl_Flush(chan) != TCL_OK) { + Tcl_AppendStringsToObj(resultPtr, "error flushing \"", + Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetsObjCmd -- + * + * This procedure is called to process the Tcl "gets" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May consume input from channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_GetsObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to read from. */ + int lineLen; /* Length of line just read. */ + int mode; /* Mode in which channel is opened. */ + char *arg; + Tcl_Obj *resultPtr, *objPtr; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); + return TCL_ERROR; + } + arg = Tcl_GetStringFromObj(objv[1], NULL); + chan = Tcl_GetChannel(interp, arg, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + resultPtr = Tcl_NewObj(); + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendStringsToObj(resultPtr, "channel \"", arg, + "\" wasn't opened for reading", (char *) NULL); + Tcl_SetObjResult(interp, resultPtr); + return TCL_ERROR; + } + + lineLen = Tcl_GetsObj(chan, resultPtr); + if (lineLen < 0) { + if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { + Tcl_SetObjLength(resultPtr, 0); + Tcl_AppendStringsToObj(resultPtr, "error reading \"", + Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), + (char *) NULL); + Tcl_SetObjResult(interp, resultPtr); + return TCL_ERROR; + } + lineLen = -1; + } + if (objc == 3) { + Tcl_ResetResult(interp); + objPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, + resultPtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + if (objPtr == NULL) { + Tcl_DecrRefCount(resultPtr); + return TCL_ERROR; + } + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), lineLen); + return TCL_OK; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReadObjCmd -- + * + * This procedure is invoked to process the Tcl "read" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May consume input from channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ReadObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to read from. */ + int newline, i; /* Discard newline at end? */ + int toRead; /* How many bytes to read? */ + int toReadNow; /* How many bytes to attempt to + * read in the current iteration? */ + int charactersRead; /* How many characters were read? */ + int charactersReadNow; /* How many characters were read + * in this iteration? */ + int mode; /* Mode in which channel is opened. */ + int bufSize; /* Channel buffer size; used to decide + * in what chunk sizes to read from + * the channel. */ + char *arg; + Tcl_Obj *resultPtr; + + if ((objc != 2) && (objc != 3)) { +argerror: + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numBytes?"); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " or \"", + Tcl_GetStringFromObj(objv[0], NULL), + " ?-nonewline? channelId\"", (char *) NULL); + return TCL_ERROR; + } + i = 1; + newline = 0; + if (strcmp(Tcl_GetStringFromObj(objv[1], NULL), "-nonewline") == 0) { + newline = 1; + i++; + } + + if (i == objc) { + goto argerror; + } + + arg = Tcl_GetStringFromObj(objv[i], NULL); + chan = Tcl_GetChannel(interp, arg, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + resultPtr = Tcl_GetObjResult(interp); + Tcl_AppendStringsToObj(resultPtr, "channel \"", arg, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + i++; /* Consumed channel name. */ + + /* + * Compute how many bytes to read, and see whether the final + * newline should be dropped. + */ + + toRead = INT_MAX; + if (i < objc) { + arg = Tcl_GetStringFromObj(objv[i], NULL); + if (isdigit((unsigned char) (arg[0]))) { + if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + } else if (strcmp(arg, "nonewline") == 0) { + newline = 1; + } else { + resultPtr = Tcl_GetObjResult(interp); + Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg, + "\": should be \"nonewline\"", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * Create a new object and use that instead of the interpreter + * result. We cannot use the interpreter's result object because + * it may get smashed at any time by recursive calls. + */ + + resultPtr = Tcl_NewObj(); + + bufSize = Tcl_GetChannelBufferSize(chan); + + /* + * If the caller specified a maximum length to read, then that is + * a good size to preallocate. + */ + + if ((toRead != INT_MAX) && (toRead > bufSize)) { + Tcl_SetObjLength(resultPtr, toRead); + } + + for (charactersRead = 0; charactersRead < toRead; ) { + toReadNow = toRead - charactersRead; + if (toReadNow > bufSize) { + toReadNow = bufSize; + } + + /* + * NOTE: This is a NOOP if we set the size (above) to the + * number of bytes we expect to read. In the degenerate + * case, however, it will grow the buffer by the channel + * buffersize, which is 4K in most cases. This will result + * in inefficient copying for large files. This will be + * fixed in a future release. + */ + + Tcl_SetObjLength(resultPtr, charactersRead + toReadNow); + charactersReadNow = + Tcl_Read(chan, Tcl_GetStringFromObj(resultPtr, NULL) + + charactersRead, toReadNow); + if (charactersReadNow < 0) { + Tcl_SetObjLength(resultPtr, 0); + Tcl_AppendStringsToObj(resultPtr, "error reading \"", + Tcl_GetChannelName(chan), "\": ", + Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, resultPtr); + + return TCL_ERROR; + } + + /* + * If we had a short read it means that we have either EOF + * or BLOCKED on the channel, so break out. + */ + + charactersRead += charactersReadNow; + + /* + * Do not call the driver again if we got a short read + */ + + if (charactersReadNow < toReadNow) { + break; /* Out of "for" loop. */ + } + } + + /* + * If requested, remove the last newline in the channel if at EOF. + */ + + if ((charactersRead > 0) && (newline) && + (Tcl_GetStringFromObj(resultPtr, NULL)[charactersRead-1] == '\n')) { + charactersRead--; + } + Tcl_SetObjLength(resultPtr, charactersRead); + + /* + * Now set the object into the interpreter result and release our + * hold on it by decrrefing it. + */ + + Tcl_SetObjResult(interp, resultPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SeekCmd -- + * + * This procedure is invoked to process the Tcl "seek" command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Moves the position of the access point on the specified channel. + * May flush queued output. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SeekCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to tell on. */ + int offset, mode; /* Where to seek? */ + int result; /* Of calling Tcl_Seek. */ + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId offset ?origin?\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) { + return TCL_ERROR; + } + mode = SEEK_SET; + if (argc == 4) { + size_t length; + int c; + + length = strlen(argv[3]); + c = argv[3][0]; + if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) { + mode = SEEK_SET; + } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) { + mode = SEEK_CUR; + } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) { + mode = SEEK_END; + } else { + Tcl_AppendResult(interp, "bad origin \"", argv[3], + "\": should be start, current, or end", (char *) NULL); + return TCL_ERROR; + } + } + + result = Tcl_Seek(chan, offset, mode); + if (result == -1) { + Tcl_AppendResult(interp, "error during seek on \"", + Tcl_GetChannelName(chan), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TellCmd -- + * + * This procedure is invoked to process the Tcl "tell" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TellCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to tell on. */ + char buf[40]; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + /* + * Try to find a channel with the right name and permissions in + * the IO channel table of this interpreter. + */ + + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + TclFormatInt(buf, Tcl_Tell(chan)); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CloseObjCmd -- + * + * This procedure is invoked to process the Tcl "close" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May discard queued input; may flush queued output. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CloseObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to close. */ + int len; /* Length of error output. */ + char *arg; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + return TCL_ERROR; + } + + arg = Tcl_GetStringFromObj(objv[1], NULL); + chan = Tcl_GetChannel(interp, arg, NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { + /* + * If there is an error message and it ends with a newline, remove + * the newline. This is done for command pipeline channels where the + * error output from the subprocesses is stored in interp->result. + * + * NOTE: This is likely to not have any effect on regular error + * messages produced by drivers during the closing of a channel, + * because the Tcl convention is that such error messages do not + * have a terminating newline. + */ + + len = strlen(interp->result); + if ((len > 0) && (interp->result[len - 1] == '\n')) { + interp->result[len - 1] = '\0'; + } + + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FconfigureCmd -- + * + * This procedure is invoked to process the Tcl "fconfigure" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May modify the behavior of an IO channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FconfigureCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to set a mode on. */ + int i; /* Iterate over arg-value pairs. */ + Tcl_DString ds; /* DString to hold result of + * calling Tcl_GetChannelOption. */ + + if ((argc < 2) || (((argc % 2) == 1) && (argc != 3))) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId ?optionName? ?value? ?optionName value?...\"", + (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (argc == 2) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + return TCL_OK; + } + if (argc == 3) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(interp, chan, argv[2], &ds) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + return TCL_OK; + } + for (i = 3; i < argc; i += 2) { + if (Tcl_SetChannelOption(interp, chan, argv[i-1], argv[i]) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EofObjCmd -- + * + * This procedure is invoked to process the Tcl "eof" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp->result to "0" or "1" depending on whether the + * specified channel has an EOF condition. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_EofObjCmd(unused, interp, objc, objv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to query for EOF. */ + int mode; /* Mode in which channel is opened. */ + char buf[40]; + char *arg; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + return TCL_ERROR; + } + + arg = Tcl_GetStringFromObj(objv[1], NULL); + chan = Tcl_GetChannel(interp, arg, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + TclFormatInt(buf, Tcl_Eof(chan) ? 1 : 0); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExecCmd -- + * + * This procedure is invoked to process the "exec" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ExecCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#ifdef MAC_TCL + Tcl_AppendResult(interp, "exec not implemented under Mac OS", + (char *)NULL); + return TCL_ERROR; +#else /* !MAC_TCL */ + int keepNewline, firstWord, background, length, result; + Tcl_Channel chan; + Tcl_DString ds; + int readSoFar, readNow, bufSize; + + /* + * Check for a leading "-keepnewline" argument. + */ + + keepNewline = 0; + for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-'); + firstWord++) { + if (strcmp(argv[firstWord], "-keepnewline") == 0) { + keepNewline = 1; + } else if (strcmp(argv[firstWord], "--") == 0) { + firstWord++; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argv[firstWord], + "\": must be -keepnewline or --", (char *) NULL); + return TCL_ERROR; + } + } + + if (argc <= firstWord) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * See if the command is to be run in background. + */ + + background = 0; + if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) { + argc--; + argv[argc] = NULL; + background = 1; + } + + chan = Tcl_OpenCommandChannel(interp, argc-firstWord, + argv+firstWord, + (background ? 0 : TCL_STDOUT | TCL_STDERR)); + + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + if (background) { + + /* + * Get the list of PIDs from the pipeline into interp->result and + * detach the PIDs (instead of waiting for them). + */ + + TclGetAndDetachPids(interp, chan); + + if (Tcl_Close(interp, chan) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; + } + + if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { +#define EXEC_BUFFER_SIZE 4096 + + Tcl_DStringInit(&ds); + readSoFar = 0; bufSize = 0; + while (1) { + bufSize += EXEC_BUFFER_SIZE; + Tcl_DStringSetLength(&ds, bufSize); + readNow = Tcl_Read(chan, Tcl_DStringValue(&ds) + readSoFar, + EXEC_BUFFER_SIZE); + if (readNow < 0) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, + "error reading output from command: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + readSoFar += readNow; + if (readNow < EXEC_BUFFER_SIZE) { + break; /* Out of "while (1)" loop. */ + } + } + Tcl_DStringSetLength(&ds, readSoFar); + Tcl_DStringResult(interp, &ds); + } + + result = Tcl_Close(interp, chan); + + /* + * If the last character of interp->result is a newline, then remove + * the newline character (the newline would just confuse things). + * Special hack: must replace the old terminating null character + * as a signal to Tcl_AppendResult et al. that we've mucked with + * the string. + */ + + length = strlen(interp->result); + if (!keepNewline && (length > 0) && + (interp->result[length-1] == '\n')) { + interp->result[length-1] = '\0'; + interp->result[length] = 'x'; + } + + return result; +#endif /* !MAC_TCL */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FblockedObjCmd -- + * + * This procedure is invoked to process the Tcl "fblocked" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp->result to "0" or "1" depending on whether the + * a preceding input operation on the channel would have blocked. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FblockedObjCmd(unused, interp, objc, objv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to query for blocked. */ + int mode; /* Mode in which channel was opened. */ + char buf[40]; + char *arg; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + return TCL_ERROR; + } + + arg = Tcl_GetStringFromObj(objv[1], NULL); + chan = Tcl_GetChannel(interp, arg, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + Tcl_GetStringFromObj(objv[1], NULL), + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + TclFormatInt(buf, Tcl_InputBlocked(chan) ? 1 : 0); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenCmd -- + * + * This procedure is invoked to process the "open" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_OpenCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int pipeline, prot; + char *modeString; + Tcl_Channel chan; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName ?access? ?permissions?\"", (char *) NULL); + return TCL_ERROR; + } + prot = 0666; + if (argc == 2) { + modeString = "r"; + } else { + modeString = argv[2]; + if (argc == 4) { + if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) { + return TCL_ERROR; + } + } + } + + pipeline = 0; + if (argv[1][0] == '|') { + pipeline = 1; + } + + /* + * Open the file or create a process pipeline. + */ + + if (!pipeline) { + chan = Tcl_OpenFileChannel(interp, argv[1], modeString, prot); + } else { +#ifdef MAC_TCL + Tcl_AppendResult(interp, + "command pipelines not supported on Macintosh OS", + (char *)NULL); + return TCL_ERROR; +#else + int mode, seekFlag, cmdArgc; + char **cmdArgv; + + if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) { + return TCL_ERROR; + } + + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + chan = NULL; + } else { + int flags = TCL_STDERR | TCL_ENFORCE_MODE; + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + flags |= TCL_STDOUT; + break; + case O_WRONLY: + flags |= TCL_STDIN; + break; + case O_RDWR: + flags |= (TCL_STDIN | TCL_STDOUT); + break; + default: + panic("Tcl_OpenCmd: invalid mode value"); + break; + } + chan = Tcl_OpenCommandChannel(interp, cmdArgc, cmdArgv, flags); + } + ckfree((char *) cmdArgv); +#endif + } + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(interp, chan); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpAcceptCallbacksDeleteProc -- + * + * Assocdata cleanup routine called when an interpreter is being + * deleted to set the interp field of all the accept callback records + * registered with the interpreter to NULL. This will prevent the + * interpreter from being used in the future to eval accept scripts. + * + * Results: + * None. + * + * Side effects: + * Deallocates memory and sets the interp field of all the accept + * callback records to NULL to prevent this interpreter from being + * used subsequently to eval accept scripts. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TcpAcceptCallbacksDeleteProc(clientData, interp) + ClientData clientData; /* Data which was passed when the assocdata + * was registered. */ + Tcl_Interp *interp; /* Interpreter being deleted - not used. */ +{ + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + AcceptCallback *acceptCallbackPtr; + + hTblPtr = (Tcl_HashTable *) clientData; + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); + acceptCallbackPtr->interp = (Tcl_Interp *) NULL; + } + Tcl_DeleteHashTable(hTblPtr); + ckfree((char *) hTblPtr); +} + +/* + *---------------------------------------------------------------------- + * + * RegisterTcpServerInterpCleanup -- + * + * Registers an accept callback record to have its interp + * field set to NULL when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * When, in the future, the interpreter is deleted, the interp + * field of the accept callback data structure will be set to + * NULL. This will prevent attempts to eval the accept script + * in a deleted interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter for which we want to be + * informed of deletion. */ + AcceptCallback *acceptCallbackPtr; + /* The accept callback record whose + * interp field we want set to NULL when + * the interpreter is deleted. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table for accept callback + * records to smash when the interpreter + * will be deleted. */ + Tcl_HashEntry *hPtr; /* Entry for this record. */ + int new; /* Is the entry new? */ + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", + NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); + (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); + } + hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); + if (!new) { + panic("RegisterTcpServerCleanup: damaged accept record table"); + } + Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); +} + +/* + *---------------------------------------------------------------------- + * + * UnregisterTcpServerInterpCleanupProc -- + * + * Unregister a previously registered accept callback record. The + * interp field of this record will no longer be set to NULL in + * the future when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * Prevents the interp field of the accept callback record from + * being set to NULL in the future when the interpreter is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter in which the accept callback + * record was registered. */ + AcceptCallback *acceptCallbackPtr; + /* The record for which to delete the + * registration. */ +{ + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return; + } + hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); + if (hPtr == (Tcl_HashEntry *) NULL) { + return; + } + Tcl_DeleteHashEntry(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * AcceptCallbackProc -- + * + * This callback is invoked by the TCP channel driver when it + * accepts a new connection from a client on a server socket. + * + * Results: + * None. + * + * Side effects: + * Whatever the script does. + * + *---------------------------------------------------------------------- + */ + +static void +AcceptCallbackProc(callbackData, chan, address, port) + ClientData callbackData; /* The data stored when the callback + * was created in the call to + * Tcl_OpenTcpServer. */ + Tcl_Channel chan; /* Channel for the newly accepted + * connection. */ + char *address; /* Address of client that was + * accepted. */ + int port; /* Port of client that was accepted. */ +{ + AcceptCallback *acceptCallbackPtr; + Tcl_Interp *interp; + char *script; + char portBuf[10]; + int result; + + acceptCallbackPtr = (AcceptCallback *) callbackData; + + /* + * Check if the callback is still valid; the interpreter may have gone + * away, this is signalled by setting the interp field of the callback + * data to NULL. + */ + + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + + script = acceptCallbackPtr->script; + interp = acceptCallbackPtr->interp; + + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) interp); + + TclFormatInt(portBuf, port); + Tcl_RegisterChannel(interp, chan); + + /* + * Artificially bump the refcount to protect the channel from + * being deleted while the script is being evaluated. + */ + + Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); + + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, (char *) NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); + Tcl_UnregisterChannel(interp, chan); + } + + /* + * Decrement the artificially bumped refcount. After this it is + * not safe anymore to use "chan", because it may now be deleted. + */ + + Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); + + Tcl_Release((ClientData) interp); + Tcl_Release((ClientData) script); + } else { + + /* + * The interpreter has been deleted, so there is no useful + * way to utilize the client socket - just close it. + */ + + Tcl_Close((Tcl_Interp *) NULL, chan); + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpServerCloseProc -- + * + * This callback is called when the TCP server channel for which it + * was registered is being closed. It informs the interpreter in + * which the accept script is evaluated (if that interpreter still + * exists) that this channel no longer needs to be informed if the + * interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * In the future, if the interpreter is deleted this channel will + * no longer be informed. + * + *---------------------------------------------------------------------- + */ + +static void +TcpServerCloseProc(callbackData) + ClientData callbackData; /* The data passed in the call to + * Tcl_CreateCloseHandler. */ +{ + AcceptCallback *acceptCallbackPtr; + /* The actual data. */ + + acceptCallbackPtr = (AcceptCallback *) callbackData; + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, + acceptCallbackPtr); + } + Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); + ckfree((char *) acceptCallbackPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SocketCmd -- + * + * This procedure is invoked to process the "socket" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates a socket based channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SocketCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int a, server, port; + char *arg, *copyScript, *host, *script; + char *myaddr = NULL; + int myport = 0; + int async = 0; + Tcl_Channel chan; + AcceptCallback *acceptCallbackPtr; + + server = 0; + script = NULL; + + if (TclHasSockets(interp) != TCL_OK) { + return TCL_ERROR; + } + + for (a = 1; a < argc; a++) { + arg = argv[a]; + if (arg[0] == '-') { + if (strcmp(arg, "-server") == 0) { + if (async == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + server = 1; + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -server option", + (char *) NULL); + return TCL_ERROR; + } + script = argv[a]; + } else if (strcmp(arg, "-myaddr") == 0) { + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -myaddr option", + (char *) NULL); + return TCL_ERROR; + } + myaddr = argv[a]; + } else if (strcmp(arg, "-myport") == 0) { + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -myport option", + (char *) NULL); + return TCL_ERROR; + } + if (TclSockGetPort(interp, argv[a], "tcp", &myport) + != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(arg, "-async") == 0) { + if (server == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + async = 1; + } else { + Tcl_AppendResult(interp, "bad option \"", arg, + "\", must be -async, -myaddr, -myport, or -server", + (char *) NULL); + return TCL_ERROR; + } + } else { + break; + } + } + if (server) { + host = myaddr; /* NULL implies INADDR_ANY */ + if (myport != 0) { + Tcl_AppendResult(interp, "Option -myport is not valid for servers", + NULL); + return TCL_ERROR; + } + } else if (a < argc) { + host = argv[a]; + a++; + } else { +wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be either:\n", + argv[0], + " ?-myaddr addr? ?-myport myport? ?-async? host port\n", + argv[0], + " -server command ?-myaddr addr? port", + (char *) NULL); + return TCL_ERROR; + } + + if (a == argc-1) { + if (TclSockGetPort(interp, argv[a], "tcp", &port) != TCL_OK) { + return TCL_ERROR; + } + } else { + goto wrongNumArgs; + } + + if (server) { + acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) + sizeof(AcceptCallback)); + copyScript = ckalloc((unsigned) strlen(script) + 1); + strcpy(copyScript, script); + acceptCallbackPtr->script = copyScript; + acceptCallbackPtr->interp = interp; + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + (ClientData) acceptCallbackPtr); + if (chan == (Tcl_Channel) NULL) { + ckfree(copyScript); + ckfree((char *) acceptCallbackPtr); + return TCL_ERROR; + } + + /* + * Register with the interpreter to let us know when the + * interpreter is deleted (by having the callback set the + * acceptCallbackPtr->interp field to NULL). This is to + * avoid trying to eval the script in a deleted interpreter. + */ + + RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); + + /* + * Register a close callback. This callback will inform the + * interpreter (if it still exists) that this channel does not + * need to be informed when the interpreter is deleted. + */ + + Tcl_CreateCloseHandler(chan, TcpServerCloseProc, + (ClientData) acceptCallbackPtr); + } else { + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + } + Tcl_RegisterChannel(interp, chan); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FcopyObjCmd -- + * + * This procedure is invoked to process the "fcopy" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Moves data between two channels and possibly sets up a + * background copy handler. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FcopyObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel inChan, outChan; + char *arg; + int mode, i; + int toRead; + Tcl_Obj *cmdPtr; + static char* switches[] = { "-size", "-command", NULL }; + enum { FcopySize, FcopyCommand } index; + + if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { + Tcl_WrongNumArgs(interp, 1, objv, + "input output ?-size size? ?-command callback?"); + return TCL_ERROR; + } + + /* + * Parse the channel arguments and verify that they are readable + * or writable, as appropriate. + */ + + arg = Tcl_GetStringFromObj(objv[1], NULL); + inChan = Tcl_GetChannel(interp, arg, &mode); + if (inChan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + Tcl_GetStringFromObj(objv[1], NULL), + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + arg = Tcl_GetStringFromObj(objv[2], NULL); + outChan = Tcl_GetChannel(interp, arg, &mode); + if (outChan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + Tcl_GetStringFromObj(objv[1], NULL), + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + toRead = -1; + cmdPtr = NULL; + for (i = 3; i < objc; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0, + (int *) &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case FcopySize: + if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { + return TCL_ERROR; + } + break; + case FcopyCommand: + cmdPtr = objv[i+1]; + break; + } + } + + return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr); +} diff --git a/tcl/generic/tclIOSock.c b/tcl/generic/tclIOSock.c new file mode 100644 index 00000000000..c3947804465 --- /dev/null +++ b/tcl/generic/tclIOSock.c @@ -0,0 +1,102 @@ +/* + * tclIOSock.c -- + * + * Common routines used by all socket based channel types. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *---------------------------------------------------------------------- + * + * TclSockGetPort -- + * + * Maps from a string, which could be a service name, to a port. + * Used by socket creation code to get port numbers and resolve + * registered service names to port numbers. + * + * Results: + * A standard Tcl result. On success, the port number is + * returned in portPtr. On failure, an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclSockGetPort(interp, string, proto, portPtr) + Tcl_Interp *interp; + char *string; /* Integer or service name */ + char *proto; /* "tcp" or "udp", typically */ + int *portPtr; /* Return port number */ +{ + struct servent *sp; /* Protocol info for named services */ + if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { + sp = getservbyname(string, proto); + if (sp != NULL) { + *portPtr = ntohs((unsigned short) sp->s_port); + Tcl_ResetResult(interp); /* clear error message */ + return TCL_OK; + } + return TCL_ERROR; + } + if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { + return TCL_ERROR; + } + if (*portPtr > 0xFFFF) { + Tcl_AppendResult(interp, "couldn't open socket: port number too high", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclSockMinimumBuffers -- + * + * Ensure minimum buffer sizes (non zero). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets SO_SNDBUF and SO_RCVBUF sizes. + * + *---------------------------------------------------------------------- + */ + +int +TclSockMinimumBuffers(sock, size) + int sock; /* Socket file descriptor */ + int size; /* Minimum buffer size */ +{ + int current; + int len; + + len = sizeof(int); + getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); + if (current < size) { + len = sizeof(int); + setsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len); + } + len = sizeof(int); + getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); + if (current < size) { + len = sizeof(int); + setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); + } + return TCL_OK; +} diff --git a/tcl/generic/tclIOUtil.c b/tcl/generic/tclIOUtil.c new file mode 100644 index 00000000000..21268b29cd0 --- /dev/null +++ b/tcl/generic/tclIOUtil.c @@ -0,0 +1,872 @@ +/* + * tclIOUtil.c -- + * + * This file contains a collection of utility procedures that + * are shared by the platform specific IO drivers. + * + * Parts of this file are based on code contributed by Karl + * Lehenbauer, Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following typedef declarations allow for hooking into the chain + * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & + * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function + * a linked list is defined. + */ + +typedef struct StatProc { + TclStatProc_ *proc; /* Function to process a 'stat()' call */ + struct StatProc *nextPtr; /* The next 'stat()' function to call */ +} StatProc; + +typedef struct AccessProc { + TclAccessProc_ *proc; /* Function to process a 'access()' call */ + struct AccessProc *nextPtr; /* The next 'access()' function to call */ +} AccessProc; + +typedef struct OpenFileChannelProc { + TclOpenFileChannelProc_ *proc; /* Function to process a + * 'Tcl_OpenFileChannel()' call */ + struct OpenFileChannelProc *nextPtr; + /* The next 'Tcl_OpenFileChannel()' + * function to call */ +} OpenFileChannelProc; + +/* + * For each type of hookable function, a static node is declared to + * hold the function pointer for the "built-in" routine (e.g. + * 'TclpStat(...)') and the respective list is initialized as a pointer + * to that node. + * + * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that + * these statically declared list entry cannot be inadvertently removed. + * + * This method avoids the need to call any sort of "initialization" + * function + */ + +static StatProc defaultStatProc = { + &TclpStat, NULL +}; +static StatProc *statProcList = &defaultStatProc; + +static AccessProc defaultAccessProc = { + &TclpAccess, NULL +}; +static AccessProc *accessProcList = &defaultAccessProc; + +static OpenFileChannelProc defaultOpenFileChannelProc = { + &TclpOpenFileChannel, NULL +}; +static OpenFileChannelProc *openFileChannelProcList = + &defaultOpenFileChannelProc; + +/* + *---------------------------------------------------------------------- + * + * TclGetOpenMode -- + * + * Description: + * Computes a POSIX mode mask for opening a file, from a given string, + * and also sets a flag to indicate whether the caller should seek to + * EOF after opening the file. + * + * Results: + * On success, returns mode to pass to "open". If an error occurs, the + * returns -1 and if interp is not NULL, sets interp->result to an + * error message. + * + * Side effects: + * Sets the integer referenced by seekFlagPtr to 1 to tell the caller + * to seek to EOF after opening the file. + * + * Special note: + * This code is based on a prototype implementation contributed + * by Mark Diekhans. + * + *---------------------------------------------------------------------- + */ + +int +TclGetOpenMode(interp, string, seekFlagPtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting - may be NULL. */ + char *string; /* Mode string, e.g. "r+" or + * "RDONLY CREAT". */ + int *seekFlagPtr; /* Set this to 1 if the caller + * should seek to EOF during the + * opening of the file. */ +{ + int mode, modeArgc, c, i, gotRW; + char **modeArgv, *flag; +#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) + + /* + * Check for the simpler fopen-like access modes (e.g. "r"). They + * are distinguished from the POSIX access modes by the presence + * of a lower-case first letter. + */ + + *seekFlagPtr = 0; + mode = 0; + if (islower(UCHAR(string[0]))) { + switch (string[0]) { + case 'r': + mode = O_RDONLY; + break; + case 'w': + mode = O_WRONLY|O_CREAT|O_TRUNC; + break; + case 'a': + mode = O_WRONLY|O_CREAT; + *seekFlagPtr = 1; + break; + default: + error: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "illegal access mode \"", string, "\"", + (char *) NULL); + } + return -1; + } + if (string[1] == '+') { + mode &= ~(O_RDONLY|O_WRONLY); + mode |= O_RDWR; + if (string[2] != 0) { + goto error; + } + } else if (string[1] != 0) { + goto error; + } + return mode; + } + + /* + * The access modes are specified using a list of POSIX modes + * such as O_CREAT. + * + * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when + * a NULL interpreter is passed in. + */ + + if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AddErrorInfo(interp, + "\n while processing open access modes \""); + Tcl_AddErrorInfo(interp, string); + Tcl_AddErrorInfo(interp, "\""); + } + return -1; + } + + gotRW = 0; + for (i = 0; i < modeArgc; i++) { + flag = modeArgv[i]; + c = flag[0]; + if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { + mode = (mode & ~RW_MODES) | O_RDONLY; + gotRW = 1; + } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { + mode = (mode & ~RW_MODES) | O_WRONLY; + gotRW = 1; + } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { + mode = (mode & ~RW_MODES) | O_RDWR; + gotRW = 1; + } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { + mode |= O_APPEND; + *seekFlagPtr = 1; + } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { + mode |= O_CREAT; + } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { + mode |= O_EXCL; + } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { +#ifdef O_NOCTTY + mode |= O_NOCTTY; +#else + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); + return -1; +#endif + } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { +#if defined(O_NDELAY) || defined(O_NONBLOCK) +# ifdef O_NONBLOCK + mode |= O_NONBLOCK; +# else + mode |= O_NDELAY; +# endif +#else + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); + return -1; +#endif + } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { + mode |= O_TRUNC; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "invalid access mode \"", flag, + "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT", + " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); + } + ckfree((char *) modeArgv); + return -1; + } + } + ckfree((char *) modeArgv); + if (!gotRW) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode must include either", + " RDONLY, WRONLY, or RDWR", (char *) NULL); + } + return -1; + } + return mode; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalFile -- + * + * Read in a file and process the entire file as one gigantic + * Tcl command. + * + * Results: + * A standard Tcl result, which is either the result of executing + * the file or an error indicating why the file couldn't be read. + * + * Side effects: + * Depends on the commands in the file. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalFile(interp, fileName) + Tcl_Interp *interp; /* Interpreter in which to process file. */ + char *fileName; /* Name of file to process. Tilde-substitution + * will be performed on this name. */ +{ + int result; + struct stat statBuf; + char *cmdBuffer = (char *) NULL; + char *oldScriptFile; + Interp *iPtr = (Interp *) interp; + Tcl_DString buffer; + char *nativeName; + Tcl_Channel chan; + Tcl_Obj *cmdObjPtr; + + Tcl_ResetResult(interp); + oldScriptFile = iPtr->scriptFile; + iPtr->scriptFile = fileName; + Tcl_DStringInit(&buffer); + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + goto error; + } + + /* + * If Tcl_TranslateFileName didn't already copy the file name, do it + * here. This way we don't depend on fileName staying constant + * throughout the execution of the script (e.g., what if it happens + * to point to a Tcl variable that the script could change?). + */ + + if (nativeName != Tcl_DStringValue(&buffer)) { + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, nativeName, -1); + nativeName = Tcl_DStringValue(&buffer); + } + if (TclStat(nativeName, &statBuf) == -1) { + Tcl_SetErrno(errno); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644); + if (chan == (Tcl_Channel) NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1); + result = Tcl_Read(chan, cmdBuffer, statBuf.st_size); + if (result < 0) { + Tcl_Close(interp, chan); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + cmdBuffer[result] = 0; + if (Tcl_Close(interp, chan) != TCL_OK) { + goto error; + } + + /* + * Transfer the buffer memory allocated above to the object system. + * Tcl_EvalObj will own this new string object if needed, + * so past the Tcl_EvalObj point, we must not ckfree(cmdBuffer) + * but rather use the reference counting mechanism. + * (Nb: and we must not thus not use goto error after this point) + */ + cmdObjPtr = Tcl_NewObj(); + cmdObjPtr->bytes = cmdBuffer; + cmdObjPtr->length = result; + + Tcl_IncrRefCount(cmdObjPtr); + result = Tcl_EvalObj(interp, cmdObjPtr); + Tcl_DecrRefCount(cmdObjPtr); + + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } else if (result == TCL_ERROR) { + char msg[200]; + + /* + * Record information telling where the error occurred. + */ + + sprintf(msg, "\n (file \"%.150s\" line %d)", fileName, + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + iPtr->scriptFile = oldScriptFile; + Tcl_DStringFree(&buffer); + return result; + +error: + if (cmdBuffer != (char *) NULL) { + ckfree(cmdBuffer); + } + iPtr->scriptFile = oldScriptFile; + Tcl_DStringFree(&buffer); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetErrno -- + * + * Gets the current value of the Tcl error code variable. This is + * currently the global variable "errno" but could in the future + * change to something else. + * + * Results: + * The value of the Tcl error code variable. + * + * Side effects: + * None. Note that the value of the Tcl error code variable is + * UNDEFINED if a call to Tcl_SetErrno did not precede this call. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetErrno() +{ + return errno; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrno -- + * + * Sets the Tcl error code variable to the supplied value. + * + * Results: + * None. + * + * Side effects: + * Modifies the value of the Tcl error code variable. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetErrno(err) + int err; /* The new value. */ +{ + errno = err; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PosixError -- + * + * This procedure is typically called after UNIX kernel calls + * return errors. It stores machine-readable information about + * the error in $errorCode returns an information string for + * the caller's use. + * + * Results: + * The return value is a human-readable string describing the + * error. + * + * Side effects: + * The global variable $errorCode is reset. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_PosixError(interp) + Tcl_Interp *interp; /* Interpreter whose $errorCode variable + * is to be changed. */ +{ + char *id, *msg; + + msg = Tcl_ErrnoMsg(errno); + id = Tcl_ErrnoId(); + Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); + return msg; +} + +/* + *---------------------------------------------------------------------- + * + * TclStat -- + * + * This procedure replaces the library version of stat and lsat. + * The chain of functions that have been "inserted" into the + * 'statProcList' will be called in succession until either + * a value of zero is returned, or the entire list is visited. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclStat(path, buf) + CONST char *path; /* Path of file to stat (in current CP). */ + TclStat_ *buf; /* Filled with results of stat call. */ +{ + StatProc *statProcPtr = statProcList; + int retVal = -1; + + /* + * Call each of the "stat" function in succession. A non-return + * value of -1 indicates the particular function has succeeded. + */ + + while ((retVal == -1) && (statProcPtr != NULL)) { + retVal = (*statProcPtr->proc)(path, buf); + statProcPtr = statProcPtr->nextPtr; + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclAccess -- + * + * This procedure replaces the library version of access. + * The chain of functions that have been "inserted" into the + * 'accessProcList' will be called in succession until either + * a value of zero is returned, or the entire list is visited. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclAccess(path, mode) + CONST char *path; /* Path of file to access (in current CP). */ + int mode; /* Permission setting. */ +{ + AccessProc *accessProcPtr = accessProcList; + int retVal = -1; + + /* + * Call each of the "access" function in succession. A non-return + * value of -1 indicates the particular function has succeeded. + */ + + while ((retVal == -1) && (accessProcPtr != NULL)) { + retVal = (*accessProcPtr->proc)(path, mode); + accessProcPtr = accessProcPtr->nextPtr; + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenFileChannel -- + * + * The chain of functions that have been "inserted" into the + * 'openFileChannelProcList' will be called in succession until + * either a valid file channel is returned, or the entire list is + * visited. + * + * Results: + * The new channel or NULL, if the named file could not be opened. + * + * Side effects: + * May open the channel and may cause creation of a file on the + * file system. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenFileChannel(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + OpenFileChannelProc *openFileChannelProcPtr = openFileChannelProcList; + Tcl_Channel retVal = NULL; + + /* + * Call each of the "Tcl_OpenFileChannel" function in succession. + * A non-NULL return value indicates the particular function has + * succeeded. + */ + + while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { + retVal = (*openFileChannelProcPtr->proc)(interp, fileName, + modeString, permissions); + openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclStatInsertProc -- + * + * Insert the passed procedure pointer at the head of the list of + * functions which are used during a call to 'TclStat(...)'. The + * passed function should be have exactly like 'TclStat' when called + * during that time (see 'TclStat(...)' for more informatin). + * The function will be added even if it already in the list. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list + * could not be allocated. + * + * Side effects: + * Memory allocataed and modifies the link list for 'TclStat' + * functions. + * + *---------------------------------------------------------------------- + */ + +int +TclStatInsertProc (proc) + TclStatProc_ *proc; +{ + int retVal = TCL_ERROR; + + if (proc != NULL) { + StatProc *newStatProcPtr; + + newStatProcPtr = (StatProc *)Tcl_Alloc(sizeof(StatProc));; + + if (newStatProcPtr != NULL) { + newStatProcPtr->proc = proc; + newStatProcPtr->nextPtr = statProcList; + statProcList = newStatProcPtr; + + retVal = TCL_OK; + } + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclStatDeleteProc -- + * + * Removed the passed function pointer from the list of 'TclStat' + * functions. Ensures that the built-in stat function is not + * removvable. + * + * Results: + * TCL_OK if the procedure pointer was successfully removed, + * TCL_ERROR otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclStatDeleteProc (proc) + TclStatProc_ *proc; +{ + int retVal = TCL_ERROR; + StatProc *tmpStatProcPtr = statProcList; + StatProc *prevStatProcPtr = NULL; + + /* + * Traverse the 'statProcList' looking for the particular node + * whose 'proc' member matches 'proc' and remove that one from + * the list. Ensure that the "default" node cannot be removed. + */ + + while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) { + if (tmpStatProcPtr->proc == proc) { + if (prevStatProcPtr == NULL) { + statProcList = tmpStatProcPtr->nextPtr; + } else { + prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; + } + + Tcl_Free((char *)tmpStatProcPtr); + + retVal = TCL_OK; + } else { + prevStatProcPtr = tmpStatProcPtr; + tmpStatProcPtr = tmpStatProcPtr->nextPtr; + } + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclAccessInsertProc -- + * + * Insert the passed procedure pointer at the head of the list of + * functions which are used during a call to 'TclAccess(...)'. The + * passed function should be have exactly like 'TclAccess' when + * called during that time (see 'TclAccess(...)' for more informatin). + * The function will be added even if it already in the list. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list + * could not be allocated. + * + * Side effects: + * Memory allocataed and modifies the link list for 'TclAccess' + * functions. + * + *---------------------------------------------------------------------- + */ + +int +TclAccessInsertProc(proc) + TclAccessProc_ *proc; +{ + int retVal = TCL_ERROR; + + if (proc != NULL) { + AccessProc *newAccessProcPtr; + + newAccessProcPtr = (AccessProc *)Tcl_Alloc(sizeof(AccessProc));; + + if (newAccessProcPtr != NULL) { + newAccessProcPtr->proc = proc; + newAccessProcPtr->nextPtr = accessProcList; + accessProcList = newAccessProcPtr; + + retVal = TCL_OK; + } + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclAccessDeleteProc -- + * + * Removed the passed function pointer from the list of 'TclAccess' + * functions. Ensures that the built-in access function is not + * removvable. + * + * Results: + * TCL_OK if the procedure pointer was successfully removed, + * TCL_ERROR otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclAccessDeleteProc(proc) + TclAccessProc_ *proc; +{ + int retVal = TCL_ERROR; + AccessProc *tmpAccessProcPtr = accessProcList; + AccessProc *prevAccessProcPtr = NULL; + + /* + * Traverse the 'accessProcList' looking for the particular node + * whose 'proc' member matches 'proc' and remove that one from + * the list. Ensure that the "default" node cannot be removed. + */ + + while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) { + if (tmpAccessProcPtr->proc == proc) { + if (prevAccessProcPtr == NULL) { + accessProcList = tmpAccessProcPtr->nextPtr; + } else { + prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; + } + + Tcl_Free((char *)tmpAccessProcPtr); + + retVal = TCL_OK; + } else { + prevAccessProcPtr = tmpAccessProcPtr; + tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; + } + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclOpenFileChannelInsertProc -- + * + * Insert the passed procedure pointer at the head of the list of + * functions which are used during a call to + * 'Tcl_OpenFileChannel(...)'. The passed function should be have + * exactly like 'Tcl_OpenFileChannel' when called during that time + * (see 'Tcl_OpenFileChannel(...)' for more informatin). The + * function will be added even if it already in the list. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list + * could not be allocated. + * + * Side effects: + * Memory allocataed and modifies the link list for + * 'Tcl_OpenFileChannel' functions. + * + *---------------------------------------------------------------------- + */ + +int +TclOpenFileChannelInsertProc(proc) + TclOpenFileChannelProc_ *proc; +{ + int retVal = TCL_ERROR; + + if (proc != NULL) { + OpenFileChannelProc *newOpenFileChannelProcPtr; + + newOpenFileChannelProcPtr = + (OpenFileChannelProc *)Tcl_Alloc(sizeof(OpenFileChannelProc));; + + if (newOpenFileChannelProcPtr != NULL) { + newOpenFileChannelProcPtr->proc = proc; + newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; + openFileChannelProcList = newOpenFileChannelProcPtr; + + retVal = TCL_OK; + } + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclOpenFileChannelDeleteProc -- + * + * Removed the passed function pointer from the list of + * 'Tcl_OpenFileChannel' functions. Ensures that the built-in + * open file channel function is not removvable. + * + * Results: + * TCL_OK if the procedure pointer was successfully removed, + * TCL_ERROR otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclOpenFileChannelDeleteProc(proc) + TclOpenFileChannelProc_ *proc; +{ + int retVal = TCL_ERROR; + OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; + OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; + + /* + * Traverse the 'openFileChannelProcList' looking for the particular + * node whose 'proc' member matches 'proc' and remove that one from + * the list. Ensure that the "default" node cannot be removed. + */ + + while ((retVal == TCL_ERROR) && + (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) { + if (tmpOpenFileChannelProcPtr->proc == proc) { + if (prevOpenFileChannelProcPtr == NULL) { + openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; + } else { + prevOpenFileChannelProcPtr->nextPtr = + tmpOpenFileChannelProcPtr->nextPtr; + } + + Tcl_Free((char *)tmpOpenFileChannelProcPtr); + + retVal = TCL_OK; + } else { + prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; + tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; + } + } + + return (retVal); +} diff --git a/tcl/generic/tclIndexObj.c b/tcl/generic/tclIndexObj.c new file mode 100644 index 00000000000..f88d216e751 --- /dev/null +++ b/tcl/generic/tclIndexObj.c @@ -0,0 +1,308 @@ +/* + * tclIndexObj.c -- + * + * This file implements objects of type "index". This object type + * is used to lookup a keyword in a table of valid values and cache + * the index of the matching entry. + * + * Copyright (c) 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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static void DupIndexInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr)); + +/* + * The structure below defines the index Tcl object type by means of + * procedures that can be invoked by generic object code. + */ + +Tcl_ObjType tclIndexType = { + "index", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + DupIndexInternalRep, /* dupIntRepProc */ + UpdateStringOfIndex, /* updateStringProc */ + SetIndexFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetIndexFromObj -- + * + * This procedure looks up an object's value in a table of strings + * and returns the index of the matching string, if any. + * + * Results: + + * If the value of objPtr is identical to or a unique abbreviation + * for one of the entries in objPtr, then the return value is + * TCL_OK and the index of the matching entry is stored at + * *indexPtr. If there isn't a proper match, then TCL_ERROR is + * returned and an error message is left in interp's result (unless + * interp is NULL). The msg argument is used in the error + * message; for example, if msg has the value "option" then the + * error message will say something flag 'bad option "foo": must be + * ...' + * + * Side effects: + * The result of the lookup is cached as the internal rep of + * objPtr, so that repeated lookups can be done quickly. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* Object containing the string to lookup. */ + char **tablePtr; /* Array of strings to compare against the + * value of objPtr; last entry must be NULL + * and there must not be duplicate entries. */ + char *msg; /* Identifying word to use in error messages. */ + int flags; /* 0 or TCL_EXACT */ + int *indexPtr; /* Place to store resulting integer index. */ +{ + int index, length, i, numAbbrev; + char *key, *p1, *p2, **entryPtr; + Tcl_Obj *resultPtr; + + /* + * See if there is a valid cached result from a previous lookup. + */ + + if ((objPtr->typePtr == &tclIndexType) + && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) { + *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2; + return TCL_OK; + } + + /* + * Lookup the value of the object in the table. Accept unique + * abbreviations unless TCL_EXACT is set in flags. + */ + + key = Tcl_GetStringFromObj(objPtr, &length); + index = -1; + numAbbrev = 0; + for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, i++) { + for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { + if (*p1 == 0) { + index = i; + goto done; + } + } + if (*p1 == 0) { + /* + * The value is an abbreviation for this entry. Continue + * checking other entries to make sure it's unique. If we + * get more than one unique abbreviation, keep searching to + * see if there is an exact match, but remember the number + * of unique abbreviations and don't allow either. + */ + + numAbbrev++; + index = i; + } + } + if ((flags & TCL_EXACT) || (numAbbrev != 1)) { + goto error; + } + + done: + if ((objPtr->typePtr != NULL) + && (objPtr->typePtr->freeIntRepProc != NULL)) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) index; + objPtr->typePtr = &tclIndexType; + *indexPtr = index; + return TCL_OK; + + error: + if (interp != NULL) { + resultPtr = Tcl_GetObjResult(interp); + Tcl_AppendStringsToObj(resultPtr, + (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", + key, "\": must be ", *tablePtr, (char *) NULL); + for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) { + if (entryPtr[1] == NULL) { + Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr, + (char *) NULL); + } else { + Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, + (char *) NULL); + } + } + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DupIndexInternalRep -- + * + * Copy the internal representation of an index Tcl_Obj from one + * object to another. + * + * Results: + * None. + * + * Side effects: + * "copyPtr"s internal rep is set to same value as "srcPtr"s + * internal rep. + * + *---------------------------------------------------------------------- + */ + +static void +DupIndexInternalRep(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + copyPtr->internalRep.twoPtrValue.ptr1 + = srcPtr->internalRep.twoPtrValue.ptr1; + copyPtr->internalRep.twoPtrValue.ptr2 + = srcPtr->internalRep.twoPtrValue.ptr2; + copyPtr->typePtr = &tclIndexType; +} + +/* + *---------------------------------------------------------------------- + * + * SetIndexFromAny -- + * + * This procedure is called to convert a Tcl object to index + * internal form. However, this doesn't make sense (need to have a + * table of keywords in order to do the conversion) so the + * procedure always generates an error. + * + * Results: + * The return value is always TCL_ERROR, and an error message is + * left in interp's result if interp isn't NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SetIndexFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "can't convert value to index except via Tcl_GetIndexFromObj API", + -1); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfIndex -- + * + * This procedure is called to update the string representation for + * an index object. It should never be called, because we never + * invalidate the string representation for an index object. + * + * Results: + * None. + * + * Side effects: + * A panic is added + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfIndex(objPtr) + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +{ + panic("UpdateStringOfIndex should never be invoked"); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WrongNumArgs -- + * + * This procedure generates a "wrong # args" error message in an + * interpreter. It is used as a utility function by many command + * procedures. + * + * Results: + * None. + * + * Side effects: + * An error message is generated in interp's result object to + * indicate that a command was invoked with the wrong number of + * arguments. The message has the form + * wrong # args: should be "foo bar additional stuff" + * where "foo" and "bar" are the initial objects in objv (objc + * determines how many of these are printed) and "additional stuff" + * is the contents of the message argument. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_WrongNumArgs(interp, objc, objv, message) + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments to print + * from objv. */ + Tcl_Obj *CONST objv[]; /* Initial argument objects, which + * should be included in the error + * message. */ + char *message; /* Error message to print after the + * leading objects in objv. The + * message may be NULL. */ +{ + Tcl_Obj *objPtr; + char **tablePtr; + int i; + + objPtr = Tcl_GetObjResult(interp); + Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); + for (i = 0; i < objc; i++) { + /* + * If the object is an index type use the index table which allows + * for the correct error message even if the subcommand was + * abbreviated. Otherwise, just use the string rep. + */ + + if (objv[i]->typePtr == &tclIndexType) { + tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1); + Tcl_AppendStringsToObj(objPtr, + tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2], + (char *) NULL); + } else { + Tcl_AppendStringsToObj(objPtr, + Tcl_GetStringFromObj(objv[i], (int *) NULL), + (char *) NULL); + } + if (i < (objc - 1)) { + Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); + } + } + if (message) { + Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL); + } + Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL); +} diff --git a/tcl/generic/tclInitScript.h b/tcl/generic/tclInitScript.h new file mode 100644 index 00000000000..975edeab3cf --- /dev/null +++ b/tcl/generic/tclInitScript.h @@ -0,0 +1,182 @@ +/* + * tclInitScript.h -- + * + * This file contains Unix & Windows common init script + * It is not used on the Mac. (the mac init script is in tclMacInit.c) + * This file should only be included once in the entire set of C + * source files for Tcl (by the respective platform initialization + * C source file, tclUnixInit.c and tclWinInit.c) and thus the + * presence of the routine, TclSetPreInitScript, below, should be + * harmless. + * + * Copyright (c) 1998 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +/* + * In order to find init.tcl during initialization, the following script + * is invoked by Tcl_Init(). It looks in several different directories: + * + * $tcl_library - can specify a primary location, if set + * no other locations will be checked + * + * $env(TCL_LIBRARY) - highest priority so user can always override + * the search path unless the application has + * specified an exact directory above + * + * $tclDefaultLibrary - this value is initialized by TclPlatformInit + * from a static C variable that was set at + * compile time + * + * <executable directory>/../lib/tcl$tcl_version + * - look for a lib/tcl<ver> in a sibling of + * the bin directory (e.g. install hierarchy) + * + * <executable directory>/../../lib/tcl$tcl_version + * - look for a lib/tcl<ver> in a sibling of + * the bin/arch directory + * + * <executable directory>/../library + * - look in build directory + * + * <executable directory>/../../library + * - look in build directory from unix/arch + * + * <executable directory>/../../tcl$tcl_patchLevel/library + * - look for tcl build directory relative + * to a parallel build directory (e.g. Tk) + * + * <executable directory>/../../../tcl$tcl_patchLevel/library + * - look for tcl build directory relative + * to a parallel build directory from + * down inside unix/arch directory + * + * The first directory on this path that contains a valid init.tcl script + * will be set as the value of tcl_library. + * + * Note that this entire search mechanism can be bypassed by defining an + * alternate tclInit procedure before calling Tcl_Init(). + */ + +static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\ + proc tclInit {} {\n\ + global tcl_library tcl_version tcl_patchLevel errorInfo\n\ + global tcl_pkgPath env tclDefaultLibrary\n\ + global tcl_platform\n\ + rename tclInit {}\n\ + set errors {}\n\ + set dirs {}\n\ + if {[info exists tcl_library]} {\n\ + lappend dirs $tcl_library\n\ + } else {\n\ + if {[info exists env(TCL_LIBRARY)]} {\n\ + lappend dirs $env(TCL_LIBRARY)\n\ + }\n\ + # CYGNUS LOCAL: I've changed this alot. Basically we only care about two cases,\n\ + # if we are installed, and if we are in the devo tree...\n\ + # The next few are for if we are installed:\n\ + set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\ + lappend dirs [file join $parentDir share tcl$tcl_version]\n\ + lappend dirs [file join [file dirname $parentDir] share tcl$tcl_version]\n\ + # NOW, let's try to find it in the build tree...\n\ + # Rather than play all the games Scriptics does, if we are in the build\n\ + # tree there will be a tclConfig.sh relative to the executible's directory, and we \n\ + # can read it and get the source dir from there...\n\ + #\n\ + # We duplicate all the directories in the search, one w/o the version and one with.\n\ + # Most modules use ../../tcl/{unix,win}\n\ + lappend configDirs [file join [file dirname $parentDir] tcl$tcl_version $tcl_platform(platform)]\n\ + lappend configDirs [file join [file dirname $parentDir] tcl $tcl_platform(platform)]\n\ + # This one gets tclsh...\n\ + lappend configDirs [info nameofexecutable]\n\ + # This one is for gdb, and any other app which has its executible in the top directory.\n\ + lappend configDirs [file join $parentDir tcl$tcl_version $tcl_platform(platform)]\n\ + lappend configDirs [file join $parentDir tcl $tcl_platform(platform)]\n\ + # This last will handle itclsh & itkwish (../../../tcl/{unix,win}):\n\ + lappend configDirs [file join [file dirname [file dirname $parentDir]] tcl$tcl_version $tcl_platform(platform)]\n\ + lappend configDirs [file join [file dirname [file dirname $parentDir]] tcl $tcl_platform(platform)]\n\ + \n\ + foreach i $configDirs {\n\ + set configFile [file join $i tclConfig.sh]\n\ + if {[file exists $configFile]} {\n\ + if {![catch {open $configFile r} fileH]} {\n\ + set srcDir {}\n\ + while {[gets $fileH line] >= 0} {\n\ + if {[regexp {^TCL_SRC_DIR='([^']*)'} $line dummy srcDir]} {\n\ + break\n\ + }\n\ + }\n\ + close $fileH\n\ + if {$srcDir != \"\"} {\n\ + lappend dirs [file join $srcDir library]\n\ + break\n\ + }\n\ + }\n\ + }\n\ + }\n\ + }\n\ + # I also moved this from just after TCL_LIBRARY to last.\n\ + # I only want to use the compiled in library if I am really lost, because\n\ + # otherwise if I have installed once, but am working in the build directory,\n\ + # I will always pick up the installed files, which will be very confusing...\n\ + lappend dirs $tclDefaultLibrary\n\ + unset tclDefaultLibrary\n\ + foreach i $dirs {\n\ + set tcl_library $i\n\ + set tclfile [file join $i init.tcl]\n\ + if {[file exists $tclfile]} {\n\ + if {![catch {uplevel #0 [list source $tclfile]} msg]} {\n\ + return\n\ + } else {\n\ + append errors \"$tclfile: $msg\n$errorInfo\n\"\n\ + }\n\ + set tcl_pkgPath [lreplace $tcl_pkgPath end end]\n\ + }\n\ + }\n\ + set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ + append msg \" $dirs\n\n\"\n\ + append msg \"$errors\n\n\"\n\ + append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ + error $msg\n\ + }\n\ +}\n\ +tclInit"; + +/* + * A pointer to a string that holds an initialization script that if non-NULL + * is evaluated in Tcl_Init() prior to the the built-in initialization script + * above. This variable can be modified by the procedure below. + */ + +static char * tclPreInitScript = NULL; + + +/* + *---------------------------------------------------------------------- + * + * TclSetPreInitScript -- + * + * This routine is used to change the value of the internal + * variable, tclPreInitScript. + * + * Results: + * Returns the current value of tclPreInitScript. + * + * Side effects: + * Changes the way Tcl_Init() routine behaves. + * + *---------------------------------------------------------------------- + */ + +char * +TclSetPreInitScript (string) + char *string; /* Pointer to a script. */ +{ + char *prevString = tclPreInitScript; + tclPreInitScript = string; + return(prevString); +} diff --git a/tcl/generic/tclInt.h b/tcl/generic/tclInt.h new file mode 100644 index 00000000000..d4b43489fe4 --- /dev/null +++ b/tcl/generic/tclInt.h @@ -0,0 +1,2147 @@ +/* + * tclInt.h -- + * + * Declarations of things used internally by the Tcl interpreter. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1993-1997 Lucent Technologies. + * Copyright (c) 1998 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#ifndef _TCLINT +#define _TCLINT + +/* + * Common include files needed by most of the Tcl source files are + * included here, so that system-dependent personalizations for the + * include files only have to be made in once place. This results + * in a few extra includes, but greater modularity. The order of + * the three groups of #includes is important. For example, stdio.h + * is needed by tcl.h, and the _ANSI_ARGS_ declaration in tcl.h is + * needed by stdlib.h in some configurations. + */ + +#include <stdio.h> + +#ifndef _TCL +#include "tcl.h" +#endif +#ifndef _REGEXP +#include "tclRegexp.h" +#endif + +#include <ctype.h> +#ifdef NO_LIMITS_H +# include "../compat/limits.h" +#else +# include <limits.h> +#endif +#ifdef NO_STDLIB_H +# include "../compat/stdlib.h" +#else +# include <stdlib.h> +#endif +#ifdef NO_STRING_H +#include "../compat/string.h" +#else +#include <string.h> +#endif +#if defined(__STDC__) || defined(HAS_STDARG) +# include <stdarg.h> +#else +# include <varargs.h> +#endif + +#ifdef BUILD_tcl +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT +#endif + +/* + * The following procedures allow namespaces to be customized to + * support special name resolution rules for commands/variables. + * + */ + +struct Tcl_ResolvedVarInfo; + +typedef Tcl_Var (Tcl_ResolveRuntimeVarProc) _ANSI_ARGS_(( + Tcl_Interp* interp, struct Tcl_ResolvedVarInfo *vinfoPtr)); + +typedef void (Tcl_ResolveVarDeleteProc) _ANSI_ARGS_(( + struct Tcl_ResolvedVarInfo *vinfoPtr)); + +/* + * The following structure encapsulates the routines needed to resolve a + * variable reference at runtime. Any variable specific state will typically + * be appended to this structure. + */ + + +typedef struct Tcl_ResolvedVarInfo { + Tcl_ResolveRuntimeVarProc *fetchProc; + Tcl_ResolveVarDeleteProc *deleteProc; +} Tcl_ResolvedVarInfo; + + + +typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_(( + Tcl_Interp* interp, char* name, int length, + Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr)); + +typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( + Tcl_Interp* interp, char* name, Tcl_Namespace *context, + int flags, Tcl_Var *rPtr)); + +typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp, + char* name, Tcl_Namespace *context, int flags, + Tcl_Command *rPtr)); + +typedef struct Tcl_ResolverInfo { + Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name + * resolution. */ + Tcl_ResolveVarProc *varResProc; /* Procedure handling variable name + * resolution for variables that + * can only be handled at runtime. */ + Tcl_ResolveCompiledVarProc *compiledVarResProc; + /* Procedure handling variable name + * resolution at compile time. */ +} Tcl_ResolverInfo; + +/* + *---------------------------------------------------------------- + * Data structures related to namespaces. + *---------------------------------------------------------------- + */ + +/* + * The structure below defines a namespace. + * Note: the first five fields must match exactly the fields in a + * Tcl_Namespace structure (see tcl.h). If you change one, be sure to + * change the other. + */ + +typedef struct Namespace { + char *name; /* The namespace's simple (unqualified) + * name. This contains no ::'s. The name of + * the global namespace is "" although "::" + * is an synonym. */ + char *fullName; /* The namespace's fully qualified name. + * This starts with ::. */ + ClientData clientData; /* An arbitrary value associated with this + * namespace. */ + Tcl_NamespaceDeleteProc *deleteProc; + /* Procedure invoked when deleting the + * namespace to, e.g., free clientData. */ + struct Namespace *parentPtr; /* Points to the namespace that contains + * this one. NULL if this is the global + * namespace. */ + Tcl_HashTable childTable; /* Contains any child namespaces. Indexed + * by strings; values have type + * (Namespace *). */ + long nsId; /* Unique id for the namespace. */ + Tcl_Interp *interp; /* The interpreter containing this + * namespace. */ + int flags; /* OR-ed combination of the namespace + * status flags NS_DYING and NS_DEAD + * listed below. */ + int activationCount; /* Number of "activations" or active call + * frames for this namespace that are on + * the Tcl call stack. The namespace won't + * be freed until activationCount becomes + * zero. */ + int refCount; /* Count of references by namespaceName * + * objects. The namespace can't be freed + * until refCount becomes zero. */ + Tcl_HashTable cmdTable; /* Contains all the commands currently + * registered in the namespace. Indexed by + * strings; values have type (Command *). + * Commands imported by Tcl_Import have + * Command structures that point (via an + * ImportedCmdRef structure) to the + * Command structure in the source + * namespace's command table. */ + Tcl_HashTable varTable; /* Contains all the (global) variables + * currently in this namespace. Indexed + * by strings; values have type (Var *). */ + char **exportArrayPtr; /* Points to an array of string patterns + * specifying which commands are exported. + * A pattern may include "string match" + * style wildcard characters to specify + * multiple commands; however, no namespace + * qualifiers are allowed. NULL if no + * export patterns are registered. */ + int numExportPatterns; /* Number of export patterns currently + * registered using "namespace export". */ + int maxExportPatterns; /* Mumber of export patterns for which + * space is currently allocated. */ + int cmdRefEpoch; /* Incremented if a newly added command + * shadows a command for which this + * namespace has already cached a Command * + * pointer; this causes all its cached + * Command* pointers to be invalidated. */ + int resolverEpoch; /* Incremented whenever the name resolution + * rules change for this namespace; this + * invalidates all byte codes compiled in + * the namespace, causing the code to be + * recompiled under the new rules. */ + Tcl_ResolveCmdProc *cmdResProc; + /* If non-null, this procedure overrides + * the usual command resolution mechanism + * in Tcl. This procedure is invoked + * within Tcl_FindCommand to resolve all + * command references within the namespace. */ + Tcl_ResolveVarProc *varResProc; + /* If non-null, this procedure overrides + * the usual variable resolution mechanism + * in Tcl. This procedure is invoked + * within Tcl_FindNamespaceVar to resolve all + * variable references within the namespace + * at runtime. */ + Tcl_ResolveCompiledVarProc *compiledVarResProc; + /* If non-null, this procedure overrides + * the usual variable resolution mechanism + * in Tcl. This procedure is invoked + * within LookupCompiledLocal to resolve + * variable references within the namespace + * at compile time. */ +} Namespace; + +/* + * Flags used to represent the status of a namespace: + * + * NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the + * namespace but there are still active call frames on the Tcl + * stack that refer to the namespace. When the last call frame + * referring to it has been popped, it's variables and command + * will be destroyed and it will be marked "dead" (NS_DEAD). + * The namespace can no longer be looked up by name. + * NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the + * namespace and no call frames still refer to it. Its + * variables and command have already been destroyed. This bit + * allows the namespace resolution code to recognize that the + * namespace is "deleted". When the last namespaceName object + * in any byte code code unit that refers to the namespace has + * been freed (i.e., when the namespace's refCount is 0), the + * namespace's storage will be freed. + */ + +#define NS_DYING 0x01 +#define NS_DEAD 0x02 + +/* + * Flag passed to TclGetNamespaceForQualName to have it create all namespace + * components of a namespace-qualified name that cannot be found. The new + * namespaces are created within their specified parent. Note that this + * flag's value must not conflict with the values of the flags + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, and FIND_ONLY_NS (defined in + * tclNamesp.c). + */ + +#define CREATE_NS_IF_UNKNOWN 0x800 + +/* + *---------------------------------------------------------------- + * Data structures related to variables. These are used primarily + * in tclVar.c + *---------------------------------------------------------------- + */ + +/* + * The following structure defines a variable trace, which is used to + * invoke a specific C procedure whenever certain operations are performed + * on a variable. + */ + +typedef struct VarTrace { + Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given + * by flags are performed on variable. */ + ClientData clientData; /* Argument to pass to proc. */ + int flags; /* What events the trace procedure is + * interested in: OR-ed combination of + * TCL_TRACE_READS, TCL_TRACE_WRITES, and + * TCL_TRACE_UNSETS. */ + struct VarTrace *nextPtr; /* Next in list of traces associated with + * a particular variable. */ +} VarTrace; + +/* + * When a variable trace is active (i.e. its associated procedure is + * executing), one of the following structures is linked into a list + * associated with the variable's interpreter. The information in + * the structure is needed in order for Tcl to behave reasonably + * if traces are deleted while traces are active. + */ + +typedef struct ActiveVarTrace { + struct Var *varPtr; /* Variable that's being traced. */ + struct ActiveVarTrace *nextPtr; + /* Next in list of all active variable + * traces for the interpreter, or NULL + * if no more. */ + VarTrace *nextTracePtr; /* Next trace to check after current + * trace procedure returns; if this + * trace gets deleted, must update pointer + * to avoid using free'd memory. */ +} ActiveVarTrace; + +/* + * The following structure describes an enumerative search in progress on + * an array variable; this are invoked with options to the "array" + * command. + */ + +typedef struct ArraySearch { + int id; /* Integer id used to distinguish among + * multiple concurrent searches for the + * same array. */ + struct Var *varPtr; /* Pointer to array variable that's being + * searched. */ + Tcl_HashSearch search; /* Info kept by the hash module about + * progress through the array. */ + Tcl_HashEntry *nextEntry; /* Non-null means this is the next element + * to be enumerated (it's leftover from + * the Tcl_FirstHashEntry call or from + * an "array anymore" command). NULL + * means must call Tcl_NextHashEntry + * to get value to return. */ + struct ArraySearch *nextPtr;/* Next in list of all active searches + * for this variable, or NULL if this is + * the last one. */ +} ArraySearch; + +/* + * The structure below defines a variable, which associates a string name + * with a Tcl_Obj value. These structures are kept in procedure call frames + * (for local variables recognized by the compiler) or in the heap (for + * global variables and any variable not known to the compiler). For each + * Var structure in the heap, a hash table entry holds the variable name and + * a pointer to the Var structure. + */ + +typedef struct Var { + union { + Tcl_Obj *objPtr; /* The variable's object value. Used for + * scalar variables and array elements. */ + Tcl_HashTable *tablePtr;/* For array variables, this points to + * information about the hash table used + * to implement the associative array. + * Points to malloc-ed data. */ + struct Var *linkPtr; /* If this is a global variable being + * referred to in a procedure, or a variable + * created by "upvar", this field points to + * the referenced variable's Var struct. */ + } value; + char *name; /* NULL if the variable is in a hashtable, + * otherwise points to the variable's + * name. It is used, e.g., by TclLookupVar + * and "info locals". The storage for the + * characters of the name is not owned by + * the Var and must not be freed when + * freeing the Var. */ + Namespace *nsPtr; /* Points to the namespace that contains + * this variable or NULL if the variable is + * a local variable in a Tcl procedure. */ + Tcl_HashEntry *hPtr; /* If variable is in a hashtable, either the + * hash table entry that refers to this + * variable or NULL if the variable has been + * detached from its hash table (e.g. an + * array is deleted, but some of its + * elements are still referred to in + * upvars). NULL if the variable is not in a + * hashtable. This is used to delete an + * variable from its hashtable if it is no + * longer needed. */ + int refCount; /* Counts number of active uses of this + * variable, not including its entry in the + * call frame or the hash table: 1 for each + * additional variable whose linkPtr points + * here, 1 for each nested trace active on + * variable, and 1 if the variable is a + * namespace variable. This record can't be + * deleted until refCount becomes 0. */ + VarTrace *tracePtr; /* First in list of all traces set for this + * variable. */ + ArraySearch *searchPtr; /* First in list of all searches active + * for this variable, or NULL if none. */ + int flags; /* Miscellaneous bits of information about + * variable. See below for definitions. */ +} Var; + +/* + * Flag bits for variables. The first three (VAR_SCALAR, VAR_ARRAY, and + * VAR_LINK) are mutually exclusive and give the "type" of the variable. + * VAR_UNDEFINED is independent of the variable's type. + * + * VAR_SCALAR - 1 means this is a scalar variable and not + * an array or link. The "objPtr" field points + * to the variable's value, a Tcl object. + * VAR_ARRAY - 1 means this is an array variable rather + * than a scalar variable or link. The + * "tablePtr" field points to the array's + * hashtable for its elements. + * VAR_LINK - 1 means this Var structure contains a + * pointer to another Var structure that + * either has the real value or is itself + * another VAR_LINK pointer. Variables like + * this come about through "upvar" and "global" + * commands, or through references to variables + * in enclosing namespaces. + * VAR_UNDEFINED - 1 means that the variable is in the process + * of being deleted. An undefined variable + * logically does not exist and survives only + * while it has a trace, or if it is a global + * variable currently being used by some + * procedure. + * VAR_IN_HASHTABLE - 1 means this variable is in a hashtable and + * the Var structure is malloced. 0 if it is + * a local variable that was assigned a slot + * in a procedure frame by the compiler so the + * Var storage is part of the call frame. + * VAR_TRACE_ACTIVE - 1 means that trace processing is currently + * underway for a read or write access, so + * new read or write accesses should not cause + * trace procedures to be called and the + * variable can't be deleted. + * VAR_ARRAY_ELEMENT - 1 means that this variable is an array + * element, so it is not legal for it to be + * an array itself (the VAR_ARRAY flag had + * better not be set). + * VAR_NAMESPACE_VAR - 1 means that this variable was declared + * as a namespace variable. This flag ensures + * it persists until its namespace is + * destroyed or until the variable is unset; + * it will persist even if it has not been + * initialized and is marked undefined. + * The variable's refCount is incremented to + * reflect the "reference" from its namespace. + * + * The following additional flags are used with the CompiledLocal type + * defined below: + * + * VAR_ARGUMENT - 1 means that this variable holds a procedure + * argument. + * VAR_TEMPORARY - 1 if the local variable is an anonymous + * temporary variable. Temporaries have a NULL + * name. + * VAR_RESOLVED - 1 if name resolution has been done for this + * variable. + */ + +#define VAR_SCALAR 0x1 +#define VAR_ARRAY 0x2 +#define VAR_LINK 0x4 +#define VAR_UNDEFINED 0x8 +#define VAR_IN_HASHTABLE 0x10 +#define VAR_TRACE_ACTIVE 0x20 +#define VAR_ARRAY_ELEMENT 0x40 +#define VAR_NAMESPACE_VAR 0x80 + +#define VAR_ARGUMENT 0x100 +#define VAR_TEMPORARY 0x200 +#define VAR_RESOLVED 0x400 + +/* + * Macros to ensure that various flag bits are set properly for variables. + * The ANSI C "prototypes" for these macros are: + * + * EXTERN void TclSetVarScalar _ANSI_ARGS_((Var *varPtr)); + * EXTERN void TclSetVarArray _ANSI_ARGS_((Var *varPtr)); + * EXTERN void TclSetVarLink _ANSI_ARGS_((Var *varPtr)); + * EXTERN void TclSetVarArrayElement _ANSI_ARGS_((Var *varPtr)); + * EXTERN void TclSetVarUndefined _ANSI_ARGS_((Var *varPtr)); + * EXTERN void TclClearVarUndefined _ANSI_ARGS_((Var *varPtr)); + */ + +#define TclSetVarScalar(varPtr) \ + (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_SCALAR + +#define TclSetVarArray(varPtr) \ + (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_LINK)) | VAR_ARRAY + +#define TclSetVarLink(varPtr) \ + (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_ARRAY)) | VAR_LINK + +#define TclSetVarArrayElement(varPtr) \ + (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT + +#define TclSetVarUndefined(varPtr) \ + (varPtr)->flags |= VAR_UNDEFINED + +#define TclClearVarUndefined(varPtr) \ + (varPtr)->flags &= ~VAR_UNDEFINED + +/* + * Macros to read various flag bits of variables. + * The ANSI C "prototypes" for these macros are: + * + * EXTERN int TclIsVarScalar _ANSI_ARGS_((Var *varPtr)); + * EXTERN int TclIsVarLink _ANSI_ARGS_((Var *varPtr)); + * EXTERN int TclIsVarArray _ANSI_ARGS_((Var *varPtr)); + * EXTERN int TclIsVarUndefined _ANSI_ARGS_((Var *varPtr)); + * EXTERN int TclIsVarArrayElement _ANSI_ARGS_((Var *varPtr)); + * EXTERN int TclIsVarTemporary _ANSI_ARGS_((Var *varPtr)); + * EXTERN int TclIsVarArgument _ANSI_ARGS_((Var *varPtr)); + * EXTERN int TclIsVarResolved _ANSI_ARGS_((Var *varPtr)); + */ + +#define TclIsVarScalar(varPtr) \ + ((varPtr)->flags & VAR_SCALAR) + +#define TclIsVarLink(varPtr) \ + ((varPtr)->flags & VAR_LINK) + +#define TclIsVarArray(varPtr) \ + ((varPtr)->flags & VAR_ARRAY) + +#define TclIsVarUndefined(varPtr) \ + ((varPtr)->flags & VAR_UNDEFINED) + +#define TclIsVarArrayElement(varPtr) \ + ((varPtr)->flags & VAR_ARRAY_ELEMENT) + +#define TclIsVarTemporary(varPtr) \ + ((varPtr)->flags & VAR_TEMPORARY) + +#define TclIsVarArgument(varPtr) \ + ((varPtr)->flags & VAR_ARGUMENT) + +#define TclIsVarResolved(varPtr) \ + ((varPtr)->flags & VAR_RESOLVED) + +/* + *---------------------------------------------------------------- + * Data structures related to procedures. These are used primarily + * in tclProc.c, tclCompile.c, and tclExecute.c. + *---------------------------------------------------------------- + */ + +/* + * Forward declaration to prevent an error when the forward reference to + * Command is encountered in the Proc and ImportRef types declared below. + */ + +struct Command; + +/* + * The variable-length structure below describes a local variable of a + * procedure that was recognized by the compiler. These variables have a + * name, an element in the array of compiler-assigned local variables in the + * procedure's call frame, and various other items of information. If the + * local variable is a formal argument, it may also have a default value. + * The compiler can't recognize local variables whose names are + * expressions (these names are only known at runtime when the expressions + * are evaluated) or local variables that are created as a result of an + * "upvar" or "uplevel" command. These other local variables are kept + * separately in a hash table in the call frame. + */ + +typedef struct CompiledLocal { + struct CompiledLocal *nextPtr; + /* Next compiler-recognized local variable + * for this procedure, or NULL if this is + * the last local. */ + int nameLength; /* The number of characters in local + * variable's name. Used to speed up + * variable lookups. */ + int frameIndex; /* Index in the array of compiler-assigned + * variables in the procedure call frame. */ + int flags; /* Flag bits for the local variable. Same as + * the flags for the Var structure above, + * although only VAR_SCALAR, VAR_ARRAY, + * VAR_LINK, VAR_ARGUMENT, VAR_TEMPORARY, and + * VAR_RESOLVED make sense. */ + Tcl_Obj *defValuePtr; /* Pointer to the default value of an + * argument, if any. NULL if not an argument + * or, if an argument, no default value. */ + Tcl_ResolvedVarInfo *resolveInfo; + /* Customized variable resolution info + * supplied by the Tcl_ResolveCompiledVarProc + * associated with a namespace. Each variable + * is marked by a unique ClientData tag + * during compilation, and that same tag + * is used to find the variable at runtime. */ + char name[4]; /* Name of the local variable starts here. + * If the name is NULL, this will just be + * '\0'. The actual size of this field will + * be large enough to hold the name. MUST + * BE THE LAST FIELD IN THE STRUCTURE! */ +} CompiledLocal; + +/* + * The structure below defines a command procedure, which consists of a + * collection of Tcl commands plus information about arguments and other + * local variables recognized at compile time. + */ + +typedef struct Proc { + struct Interp *iPtr; /* Interpreter for which this command + * is defined. */ + int refCount; /* Reference count: 1 if still present + * in command table plus 1 for each call + * to the procedure that is currently + * active. This structure can be freed + * when refCount becomes zero. */ + struct Command *cmdPtr; /* Points to the Command structure for + * this procedure. This is used to get + * the namespace in which to execute + * the procedure. */ + Tcl_Obj *bodyPtr; /* Points to the ByteCode object for + * procedure's body command. */ + int numArgs; /* Number of formal parameters. */ + int numCompiledLocals; /* Count of local variables recognized by + * the compiler including arguments and + * temporaries. */ + CompiledLocal *firstLocalPtr; /* Pointer to first of the procedure's + * compiler-allocated local variables, or + * NULL if none. The first numArgs entries + * in this list describe the procedure's + * formal arguments. */ + CompiledLocal *lastLocalPtr; /* Pointer to the last allocated local + * variable or NULL if none. This has + * frame index (numCompiledLocals-1). */ +} Proc; + +/* + * The structure below defines a command trace. This is used to allow Tcl + * clients to find out whenever a command is about to be executed. + */ + +typedef struct Trace { + int level; /* Only trace commands at nesting level + * less than or equal to this. */ + Tcl_CmdTraceProc *proc; /* Procedure to call to trace command. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ + struct Trace *nextPtr; /* Next in list of traces for this interp. */ +} Trace; + +/* + * The structure below defines an entry in the assocData hash table which + * is associated with an interpreter. The entry contains a pointer to a + * function to call when the interpreter is deleted, and a pointer to + * a user-defined piece of data. + */ + +typedef struct AssocData { + Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ + ClientData clientData; /* Value to pass to proc. */ +} AssocData; + +/* + * The structure below defines a call frame. A call frame defines a naming + * context for a procedure call: its local naming scope (for local + * variables) and its global naming scope (a namespace, perhaps the global + * :: namespace). A call frame can also define the naming context for a + * namespace eval or namespace inscope command: the namespace in which the + * command's code should execute. The Tcl_CallFrame structures exist only + * while procedures or namespace eval/inscope's are being executed, and + * provide a kind of Tcl call stack. + * + * WARNING!! The structure definition must be kept consistent with the + * Tcl_CallFrame structure in tcl.h. If you change one, change the other. + */ + +typedef struct CallFrame { + Namespace *nsPtr; /* Points to the namespace used to resolve + * commands and global variables. */ + int isProcCallFrame; /* If nonzero, the frame was pushed to + * execute a Tcl procedure and may have + * local vars. If 0, the frame was pushed + * to execute a namespace command and var + * references are treated as references to + * namespace vars; varTablePtr and + * compiledLocals are ignored. */ + int objc; /* This and objv below describe the + * arguments for this procedure call. */ + Tcl_Obj *CONST *objv; /* Array of argument objects. */ + struct CallFrame *callerPtr; + /* Value of interp->framePtr when this + * procedure was invoked (i.e. next higher + * in stack of all active procedures). */ + struct CallFrame *callerVarPtr; + /* Value of interp->varFramePtr when this + * procedure was invoked (i.e. determines + * variable scoping within caller). Same + * as callerPtr unless an "uplevel" command + * or something equivalent was active in + * the caller). */ + int level; /* Level of this procedure, for "uplevel" + * purposes (i.e. corresponds to nesting of + * callerVarPtr's, not callerPtr's). 1 for + * outermost procedure, 0 for top-level. */ + Proc *procPtr; /* Points to the structure defining the + * called procedure. Used to get information + * such as the number of compiled local + * variables (local variables assigned + * entries ["slots"] in the compiledLocals + * array below). */ + Tcl_HashTable *varTablePtr; /* Hash table containing local variables not + * recognized by the compiler, or created at + * execution time through, e.g., upvar. + * Initially NULL and created if needed. */ + int numCompiledLocals; /* Count of local variables recognized by + * the compiler including arguments. */ + Var* compiledLocals; /* Points to the array of local variables + * recognized by the compiler. The compiler + * emits code that refers to these variables + * using an index into this array. */ +} CallFrame; + +/* + *---------------------------------------------------------------- + * Data structures related to history. These are used primarily + * in tclHistory.c + *---------------------------------------------------------------- + */ + +/* + * The structure below defines one history event (a previously-executed + * command that can be re-executed in whole or in part). + */ + +typedef struct { + char *command; /* String containing previously-executed + * command. */ + int bytesAvl; /* Total # of bytes available at *event (not + * all are necessarily in use now). */ +} HistoryEvent; + +/* + * The structure below defines a pending revision to the most recent + * history event. Changes are linked together into a list and applied + * during the next call to Tcl_RecordHistory. See the comments at the + * beginning of tclHistory.c for information on revisions. + */ + +typedef struct HistoryRev { + int firstIndex; /* Index of the first byte to replace in + * current history event. */ + int lastIndex; /* Index of last byte to replace in + * current history event. */ + int newSize; /* Number of bytes in newBytes. */ + char *newBytes; /* Replacement for the range given by + * firstIndex and lastIndex (malloced). */ + struct HistoryRev *nextPtr; /* Next in chain of revisions to apply, or + * NULL for end of list. */ +} HistoryRev; + +/* + *---------------------------------------------------------------- + * Data structures related to expressions. These are used only in + * tclExpr.c. + *---------------------------------------------------------------- + */ + +/* + * The data structure below defines a math function (e.g. sin or hypot) + * for use in Tcl expressions. + */ + +#define MAX_MATH_ARGS 5 +typedef struct MathFunc { + int builtinFuncIndex; /* If this is a builtin math function, its + * index in the array of builtin functions. + * (tclCompilation.h lists these indices.) + * The value is -1 if this is a new function + * defined by Tcl_CreateMathFunc. The value + * is also -1 if a builtin function is + * replaced by a Tcl_CreateMathFunc call. */ + 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. + * NULL if isBuiltinFunc is 1. */ + ClientData clientData; /* Additional argument to pass to the + * function when invoking it. NULL if + * isBuiltinFunc is 1. */ +} MathFunc; + +/* + *---------------------------------------------------------------- + * Data structures related to bytecode compilation and execution. + * These are used primarily in tclCompile.c, tclExecute.c, and + * tclBasic.c. + *---------------------------------------------------------------- + */ + +/* + * Forward declaration to prevent an error when the forward reference to + * CompileEnv is encountered in the procedure type CompileProc declared + * below. + */ + +struct CompileEnv; + +/* + * The type of procedures called by the Tcl bytecode compiler to compile + * commands. Pointers to these procedures are kept in the Command structure + * describing each command. When a CompileProc returns, the interpreter's + * result is set to error information, if any. In addition, the CompileProc + * returns an integer value, which is one of the following: + * + * TCL_OK Compilation completed normally. + * TCL_ERROR Compilation failed because of an error; + * the interpreter's result describes what went wrong. + * TCL_OUT_LINE_COMPILE Compilation failed because, e.g., the command is + * too complex for effective inline compilation. The + * CompileProc believes the command is legal but + * should be compiled "out of line" by emitting code + * to invoke its command procedure at runtime. + */ + +#define TCL_OUT_LINE_COMPILE (TCL_CONTINUE + 1) + +typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, char *string, + char *lastChar, int compileFlags, struct CompileEnv *compEnvPtr)); + +/* + * The data structure defining the execution environment for ByteCode's. + * There is one ExecEnv structure per Tcl interpreter. It holds the + * evaluation stack that holds command operands and results. The stack grows + * towards increasing addresses. The "stackTop" member is cached by + * TclExecuteByteCode in a local variable: it must be set before calling + * TclExecuteByteCode and will be restored by TclExecuteByteCode before it + * returns. + */ + +typedef union StackItem { + Tcl_Obj *o; /* Stack item as a pointer to a Tcl_Obj. */ + int i; /* Stack item as an integer. */ + VOID *p; /* Stack item as an arbitrary pointer. */ +} StackItem; + +typedef struct ExecEnv { + StackItem *stackPtr; /* Points to the first item in the + * evaluation stack on the heap. */ + int stackTop; /* Index of current top of stack; -1 when + * the stack is empty. */ + int stackEnd; /* Index of last usable item in stack. */ +} ExecEnv; + +/* + *---------------------------------------------------------------- + * Data structures related to commands. + *---------------------------------------------------------------- + */ + +/* + * An imported command is created in an namespace when it imports a "real" + * command from another namespace. An imported command has a Command + * structure that points (via its ClientData value) to the "real" Command + * structure in the source namespace's command table. The real command + * records all the imported commands that refer to it in a list of ImportRef + * structures so that they can be deleted when the real command is deleted. */ + +typedef struct ImportRef { + struct Command *importedCmdPtr; + /* Points to the imported command created in + * an importing namespace; this command + * redirects its invocations to the "real" + * command. */ + struct ImportRef *nextPtr; /* Next element on the linked list of + * imported commands that refer to the + * "real" command. The real command deletes + * these imported commands on this list when + * it is deleted. */ +} ImportRef; + +/* + * Data structure used as the ClientData of imported commands: commands + * created in an namespace when it imports a "real" command from another + * namespace. + */ + +typedef struct ImportedCmdData { + struct Command *realCmdPtr; /* "Real" command that this imported command + * refers to. */ + struct Command *selfPtr; /* Pointer to this imported command. Needed + * only when deleting it in order to remove + * it from the real command's linked list of + * imported commands that refer to it. */ +} ImportedCmdData; + +/* + * A Command structure exists for each command in a namespace. The + * Tcl_Command opaque type actually refers to these structures. + */ + +typedef struct Command { + Tcl_HashEntry *hPtr; /* Pointer to the hash table entry that + * refers to this command. The hash table is + * either a namespace's command table or an + * interpreter's hidden command table. This + * pointer is used to get a command's name + * from its Tcl_Command handle. NULL means + * that the hash table entry has been + * removed already (this can happen if + * deleteProc causes the command to be + * deleted or recreated). */ + Namespace *nsPtr; /* Points to the namespace containing this + * command. */ + int refCount; /* 1 if in command hashtable plus 1 for each + * reference from a CmdName Tcl object + * representing a command's name in a + * ByteCode instruction sequence. This + * structure can be freed when refCount + * becomes zero. */ + int cmdEpoch; /* Incremented to invalidate any references + * that point to this command when it is + * renamed, deleted, hidden, or exposed. */ + CompileProc *compileProc; /* Procedure called to compile command. NULL + * if no compile proc exists for command. */ + Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */ + ClientData objClientData; /* Arbitrary value passed to object proc. */ + Tcl_CmdProc *proc; /* String-based command procedure. */ + ClientData clientData; /* Arbitrary value passed to string proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* Procedure invoked when deleting command + * to, e.g., free all client data. */ + ClientData deleteData; /* Arbitrary value passed to deleteProc. */ + int deleted; /* Means that the command is in the process + * of being deleted (its deleteProc is + * currently executing). Other attempts to + * delete the command should be ignored. */ + ImportRef *importRefPtr; /* List of each imported Command created in + * another namespace when this command is + * imported. These imported commands + * redirect invocations back to this + * command. The list is used to remove all + * those imported commands when deleting + * this "real" command. */ +} Command; + +/* + *---------------------------------------------------------------- + * Data structures related to name resolution procedures. + *---------------------------------------------------------------- + */ + +/* + * The interpreter keeps a linked list of name resolution schemes. + * The scheme for a namespace is consulted first, followed by the + * list of schemes in an interpreter, followed by the default + * name resolution in Tcl. Schemes are added/removed from the + * interpreter's list by calling Tcl_AddInterpResolver and + * Tcl_RemoveInterpResolver. + */ + +typedef struct ResolverScheme { + char *name; /* Name identifying this scheme. */ + Tcl_ResolveCmdProc *cmdResProc; + /* Procedure handling command name + * resolution. */ + Tcl_ResolveVarProc *varResProc; + /* Procedure handling variable name + * resolution for variables that + * can only be handled at runtime. */ + Tcl_ResolveCompiledVarProc *compiledVarResProc; + /* Procedure handling variable name + * resolution at compile time. */ + + struct ResolverScheme *nextPtr; + /* Pointer to next record in linked list. */ +} ResolverScheme; + +/* + *---------------------------------------------------------------- + * This structure defines an interpreter, which is a collection of + * commands plus other state information related to interpreting + * commands, such as variable storage. Primary responsibility for + * this data structure is in tclBasic.c, but almost every Tcl + * source file uses something in here. + *---------------------------------------------------------------- + */ + +typedef struct Interp { + + /* + * Note: the first three fields must match exactly the fields in + * a Tcl_Interp struct (see tcl.h). If you change one, be sure to + * change the other. + * + * The interpreter's result is held in both the string and the + * objResultPtr fields. These fields hold, respectively, the result's + * string or object value. The interpreter's result is always in the + * result field if that is non-empty, otherwise it is in objResultPtr. + * The two fields are kept consistent unless some C code sets + * interp->result directly. Programs should not access result and + * objResultPtr directly; instead, they should always get and set the + * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, + * and Tcl_GetStringResult. See the SetResult man page for details. + */ + + char *result; /* If the last command returned a string + * result, this points to it. Should not be + * accessed directly; see comment above. */ + Tcl_FreeProc *freeProc; /* Zero means a string result is statically + * allocated. TCL_DYNAMIC means string + * result was allocated with ckalloc and + * should be freed with ckfree. Other values + * give address of procedure to invoke to + * free the string result. Tcl_Eval must + * free it before executing next command. */ + int errorLine; /* When TCL_ERROR is returned, this gives + * the line number in the command where the + * error occurred (1 means first line). */ + Tcl_Obj *objResultPtr; /* If the last command returned an object + * result, this points to it. Should not be + * accessed directly; see comment above. */ + Namespace *globalNsPtr; /* The interpreter's global namespace. */ + Tcl_HashTable mathFuncTable;/* Contains all the math functions currently + * defined for the interpreter. Indexed by + * strings (function names); values have + * type (MathFunc *). */ + + /* + * Information related to procedures and variables. See tclProc.c + * and tclvar.c for usage. + */ + + int numLevels; /* Keeps track of how many nested calls to + * Tcl_Eval are in progress for this + * interpreter. It's used to delay deletion + * of the table until all Tcl_Eval + * invocations are completed. */ + int maxNestingDepth; /* If numLevels exceeds this value then Tcl + * assumes that infinite recursion has + * occurred and it generates an error. */ + CallFrame *framePtr; /* Points to top-most in stack of all nested + * procedure invocations. NULL means there + * are no active procedures. */ + CallFrame *varFramePtr; /* Points to the call frame whose variables + * are currently in use (same as framePtr + * unless an "uplevel" command is + * executing). NULL means no procedure is + * active or "uplevel 0" is executing. */ + ActiveVarTrace *activeTracePtr; + /* First in list of active traces for + * interp, or NULL if no active traces. */ + int returnCode; /* Completion code to return if current + * procedure exits with TCL_RETURN code. */ + char *errorInfo; /* Value to store in errorInfo if returnCode + * is TCL_ERROR. Malloc'ed, may be NULL */ + char *errorCode; /* Value to store in errorCode if returnCode + * is TCL_ERROR. Malloc'ed, may be NULL */ + + /* + * Information used by Tcl_AppendResult to keep track of partial + * results. See Tcl_AppendResult code for details. + */ + + char *appendResult; /* Storage space for results generated + * by Tcl_AppendResult. Malloc-ed. NULL + * means not yet allocated. */ + int appendAvl; /* Total amount of space available at + * partialResult. */ + int appendUsed; /* Number of non-null bytes currently + * stored at partialResult. */ + + /* + * A cache of compiled regular expressions. See Tcl_RegExpCompile + * in tclUtil.c for details. + */ + +#define NUM_REGEXPS 5 + char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled + * regular expression patterns. NULL + * means that this slot isn't used. + * Malloc-ed. */ + int patLengths[NUM_REGEXPS];/* Number of non-null characters in + * corresponding entry in patterns. + * -1 means entry isn't used. */ + regexp *regexps[NUM_REGEXPS]; + /* Compiled forms of above strings. Also + * malloc-ed, or NULL if not in use yet. */ + + /* + * Information about packages. Used only in tclPkg.c. + */ + + Tcl_HashTable packageTable; /* Describes all of the packages loaded + * in or available to this interpreter. + * Keys are package names, values are + * (Package *) pointers. */ + char *packageUnknown; /* Command to invoke during "package + * require" commands for packages that + * aren't described in packageTable. + * Malloc'ed, may be NULL. */ + + /* + * Miscellaneous information: + */ + + int cmdCount; /* Total number of times a command procedure + * has been called for this interpreter. */ + int evalFlags; /* Flags to control next call to Tcl_Eval. + * Normally zero, but may be set before + * calling Tcl_Eval. See below for valid + * values. */ + int termOffset; /* Offset of character just after last one + * compiled or executed by Tcl_EvalObj. */ + int compileEpoch; /* Holds the current "compilation epoch" + * for this interpreter. This is + * incremented to invalidate existing + * ByteCodes when, e.g., a command with a + * compile procedure is redefined. */ + Proc *compiledProcPtr; /* If a procedure is being compiled, a + * pointer to its Proc structure; otherwise, + * this is NULL. Set by ObjInterpProc in + * tclProc.c and used by tclCompile.c to + * process local variables appropriately. */ + ResolverScheme *resolverPtr; + /* Linked list of name resolution schemes + * added to this interpreter. Schemes + * are added/removed by calling + * Tcl_AddInterpResolver and + * Tcl_RemoveInterpResolver. */ + char *scriptFile; /* NULL means there is no nested source + * command active; otherwise this points to + * the name of the file being sourced (it's + * not malloc-ed: it points to an argument + * to Tcl_EvalFile. */ + int flags; /* Various flag bits. See below. */ + long randSeed; /* Seed used for rand() function. */ + Trace *tracePtr; /* List of traces for this interpreter. */ + Tcl_HashTable *assocData; /* Hash table for associating data with + * this interpreter. Cleaned up when + * this interpreter is deleted. */ + struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode + * execution. Contains a pointer to the + * Tcl evaluation stack. */ + Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty + * string. Returned by Tcl_ObjSetVar2 when + * variable traces change a variable in a + * gross way. */ + char resultSpace[TCL_RESULT_SIZE+1]; + /* Static space holding small results. */ +} Interp; + +/* + * EvalFlag bits for Interp structures: + * + * TCL_BRACKET_TERM 1 means that the current script is terminated by + * a close bracket rather than the end of the string. + * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with + * a code other than TCL_OK or TCL_ERROR; 0 means + * codes other than these should be turned into errors. + */ + +#define TCL_BRACKET_TERM 1 +#define TCL_ALLOW_EXCEPTIONS 4 + +/* + * Flag bits for Interp structures: + * + * DELETED: Non-zero means the interpreter has been deleted: + * don't process any more commands for it, and destroy + * the structure as soon as all nested invocations of + * Tcl_Eval are done. + * ERR_IN_PROGRESS: Non-zero means an error unwind is already in + * progress. Zero means a command proc has been + * invoked since last error occured. + * ERR_ALREADY_LOGGED: Non-zero means information has already been logged + * in $errorInfo for the current Tcl_Eval instance, + * so Tcl_Eval needn't log it (used to implement the + * "error message log" command). + * ERROR_CODE_SET: Non-zero means that Tcl_SetErrorCode has been + * called to record information for the current + * error. Zero means Tcl_Eval must clear the + * errorCode variable if an error is returned. + * EXPR_INITIALIZED: Non-zero means initialization specific to + * expressions has been carried out. + * DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler + * should not compile any commands into an inline + * sequence of instructions. This is set 1, for + * example, when command traces are requested. + * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the + * interp has not be initialized. This is set 1 + * when we first use the rand() or srand() functions. + * SAFE_INTERP: Non zero means that the current interp is a + * safe interp (ie it has only the safe commands + * installed, less priviledge than a regular interp). + */ + +#define DELETED 1 +#define ERR_IN_PROGRESS 2 +#define ERR_ALREADY_LOGGED 4 +#define ERROR_CODE_SET 8 +#define EXPR_INITIALIZED 0x10 +#define DONT_COMPILE_CMDS_INLINE 0x20 +#define RAND_SEED_INITIALIZED 0x40 +#define SAFE_INTERP 0x80 + +/* + *---------------------------------------------------------------- + * Data structures related to command parsing. These are used in + * tclParse.c and its clients. + *---------------------------------------------------------------- + */ + +/* + * The following data structure is used by various parsing procedures + * to hold information about where to store the results of parsing + * (e.g. the substituted contents of a quoted argument, or the result + * of a nested command). At any given time, the space available + * for output is fixed, but a procedure may be called to expand the + * space available if the current space runs out. + */ + +typedef struct ParseValue { + char *buffer; /* Address of first character in + * output buffer. */ + char *next; /* Place to store next character in + * output buffer. */ + char *end; /* Address of the last usable character + * in the buffer. */ + void (*expandProc) _ANSI_ARGS_((struct ParseValue *pvPtr, int needed)); + /* Procedure to call when space runs out; + * it will make more space. */ + ClientData clientData; /* Arbitrary information for use of + * expandProc. */ +} ParseValue; + +/* + * A table used to classify input characters to assist in parsing + * Tcl commands. The table should be indexed with a signed character + * using the CHAR_TYPE macro. The character may have a negative + * value. The CHAR_TYPE macro takes a pointer to a signed character + * and a pointer to the last character in the source string. If the + * src pointer is pointing at the terminating null of the string, + * CHAR_TYPE returns TCL_COMMAND_END. + */ + +extern unsigned char tclTypeTable[]; +#define CHAR_TYPE(src,last) \ + (((src)==(last))?TCL_COMMAND_END:(tclTypeTable)[(int)(*(src) + 128)]) + +/* + * Possible values returned by CHAR_TYPE. Note that except for TCL_DOLLAR, + * these are all one byte values with a single bit set 1. This means these + * values may be bit-or'ed together (except for TCL_DOLLAR) to quickly test + * whether a character is one of several different kinds of characters. + * + * TCL_NORMAL - All characters that don't have special significance + * to the Tcl language. + * TCL_SPACE - Character is space, tab, or return. + * TCL_COMMAND_END - Character is newline or semicolon or close-bracket + * or terminating null. + * TCL_QUOTE - Character is a double-quote. + * TCL_OPEN_BRACKET - Character is a "[". + * TCL_OPEN_BRACE - Character is a "{". + * TCL_CLOSE_BRACE - Character is a "}". + * TCL_BACKSLASH - Character is a "\". + * TCL_DOLLAR - Character is a "$". + */ + +#define TCL_NORMAL 0x01 +#define TCL_SPACE 0x02 +#define TCL_COMMAND_END 0x04 +#define TCL_QUOTE 0x08 +#define TCL_OPEN_BRACKET 0x10 +#define TCL_OPEN_BRACE 0x20 +#define TCL_CLOSE_BRACE 0x40 +#define TCL_BACKSLASH 0x80 +#define TCL_DOLLAR 0x00 + +/* + * Maximum number of levels of nesting permitted in Tcl commands (used + * to catch infinite recursion). + */ + +#define MAX_NESTING_DEPTH 1000 + +/* + * The macro below is used to modify a "char" value (e.g. by casting + * it to an unsigned character) so that it can be used safely with + * macros such as isspace. + */ + +#define UCHAR(c) ((unsigned char) (c)) + +/* + * This macro is used to determine the offset needed to safely allocate any + * data structure in memory. Given a starting offset or size, it "rounds up" + * or "aligns" the offset to the next 8-byte boundary so that any data + * structure can be placed at the resulting offset without fear of an + * alignment error. + * + * WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce + * the wrong result on platforms that allocate addresses that are divisible + * by 4 or 2. Only use it for offsets or sizes. + */ + +#define TCL_ALIGN(x) (((int)(x) + 7) & ~7) + +/* + * The following macros are used to specify the runtime platform + * setting of the tclPlatform variable. + */ + +typedef enum { + TCL_PLATFORM_UNIX, /* Any Unix-like OS. */ + TCL_PLATFORM_MAC, /* MacOS. */ + TCL_PLATFORM_WINDOWS /* Any Microsoft Windows OS. */ +} TclPlatformType; + +/* + * Flags for TclInvoke: + * + * TCL_INVOKE_HIDDEN Invoke a hidden command; if not set, + * invokes an exposed command. + * TCL_INVOKE_NO_UNKNOWN If set, "unknown" is not invoked if + * the command to be invoked is not found. + * Only has an effect if invoking an exposed + * command, i.e. if TCL_INVOKE_HIDDEN is not + * also set. + */ + +#define TCL_INVOKE_HIDDEN (1<<0) +#define TCL_INVOKE_NO_UNKNOWN (1<<1) + +/* + * The structure used as the internal representation of Tcl list + * objects. This is an array of pointers to the element objects. This array + * is grown (reallocated and copied) as necessary to hold all the list's + * element pointers. The array might contain more slots than currently used + * to hold all element pointers. This is done to make append operations + * faster. + */ + +typedef struct List { + int maxElemCount; /* Total number of element array slots. */ + int elemCount; /* Current number of list elements. */ + Tcl_Obj **elements; /* Array of pointers to element objects. */ +} List; + +/* + * The following types are used for getting and storing platform-specific + * file attributes in tclFCmd.c and the various platform-versions of + * that file. This is done to have as much common code as possible + * in the file attributes code. For more information about the callbacks, + * see TclFileAttrsCmd in tclFCmd.c. + */ + +typedef int (TclGetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj **attrObjPtrPtr)); +typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, + int objIndex, char *fileName, + Tcl_Obj *attrObjPtr)); + +typedef struct TclFileAttrProcs { + TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */ + TclSetFileAttrProc *setProc; /* The procedure for setting attrs. */ +} TclFileAttrProcs; + +/* + * Opaque handle used in pipeline routines to encapsulate platform-dependent + * state. + */ + +typedef struct TclFile_ *TclFile; + +/* + *---------------------------------------------------------------- + * Data structures related to hooking 'TclStat(...)' and + * 'TclAccess(...)'. + *---------------------------------------------------------------- + */ + +typedef struct stat TclStat_; +typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, TclStat_ *buf)); +typedef int (TclAccessProc_) _ANSI_ARGS_((CONST char *path, int mode)); +typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *modeString, + int permissions)); + +typedef int (*TclCmdProcType) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); +typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[])); + +/* + *---------------------------------------------------------------- + * Variables shared among Tcl modules but not used by the outside world. + *---------------------------------------------------------------- + */ + +extern Tcl_Time tclBlockTime; +extern int tclBlockTimeSet; +extern char * tclExecutableName; +extern Tcl_ChannelType tclFileChannelType; +extern char * tclMemDumpFileName; +extern TclPlatformType tclPlatform; +extern char * tclpFileAttrStrings[]; +extern CONST TclFileAttrProcs tclpFileAttrProcs[]; + +/* + * Variables denoting the Tcl object types defined in the core. + */ + +extern Tcl_ObjType tclBooleanType; +extern Tcl_ObjType tclByteCodeType; +extern Tcl_ObjType tclDoubleType; +extern Tcl_ObjType tclIntType; +extern Tcl_ObjType tclListType; +extern Tcl_ObjType tclProcBodyType; +extern Tcl_ObjType tclStringType; + +/* + * The head of the list of free Tcl objects, and the total number of Tcl + * objects ever allocated and freed. + */ + +extern Tcl_Obj * tclFreeObjList; + +#ifdef TCL_COMPILE_STATS +extern long tclObjsAlloced; +extern long tclObjsFreed; +#endif /* TCL_COMPILE_STATS */ + +/* + * Pointer to a heap-allocated string of length zero that the Tcl core uses + * as the value of an empty string representation for an object. This value + * is shared by all new objects allocated by Tcl_NewObj. + */ + +extern char * tclEmptyStringRep; + +/* + *---------------------------------------------------------------- + * Procedures shared among Tcl modules but not used by the outside + * world: + *---------------------------------------------------------------- + */ + +EXTERN void panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); +EXTERN int TclAccess _ANSI_ARGS_((CONST char *path, + int mode)); +EXTERN int TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc)); +EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc)); +EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); +EXTERN int TclChdir _ANSI_ARGS_((Tcl_Interp *interp, + char *dirName)); +EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, + int numPids, Tcl_Pid *pidPtr, + Tcl_Channel errorChan)); +EXTERN void TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr)); +EXTERN int TclCopyAndCollapse _ANSI_ARGS_((int count, + char *src, char *dst)); +EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel inChan, Tcl_Channel outChan, + int toRead, Tcl_Obj *cmdPtr)); +/* + * TclCreatePipeline unofficially exported for use by BLT. + */ +EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, Tcl_Pid **pidArrayPtr, + TclFile *inPipePtr, TclFile *outPipePtr, + TclFile *errFilePtr)); +EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp *interp, + Namespace *nsPtr, char *procName, + Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, + Proc **procPtrPtr)); +EXTERN void TclDeleteCompiledLocalVars _ANSI_ARGS_(( + Interp *iPtr, CallFrame *framePtr)); +EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, + Tcl_HashTable *tablePtr)); +EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *headPtr, + char *tail)); +EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile)); +EXTERN void TclExpandParseValue _ANSI_ARGS_((ParseValue *pvPtr, + int needed)); +EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, + double value)); +EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); +EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void)); +EXTERN void TclFinalizeExecEnv _ANSI_ARGS_((void)); +EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp, + char *list, int listLength, char **elementPtr, + char **nextPtr, int *sizePtr, int *bracePtr)); +EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, + char *procName)); +EXTERN int TclFormatInt _ANSI_ARGS_((char *buffer, long n)); +EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr)); +EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclGetDate _ANSI_ARGS_((char *p, + unsigned long now, long zone, + unsigned long *timePtr)); +EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type)); +EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( + Tcl_Interp *interp, int localIndex, + Tcl_Obj *elemPtr, int leaveErrorMsg)); +EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char *name)); +EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); +EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, + char *string, CallFrame **framePtrPtr)); +EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void)); +EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int endValue, int *indexPtr)); +EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, + int localIndex, int leaveErrorMsg)); +EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp *interp, + char *string, long *longPtr)); +EXTERN int TclGetLoadedPackages _ANSI_ARGS_(( + Tcl_Interp *interp, char *targetName)); +EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_(( + Tcl_Interp *interp, char *qualName, + Namespace *cxtNsPtr, int flags, + Namespace **nsPtrPtr, Namespace **altNsPtrPtr, + Namespace **actualCxtPtrPtr, + char **simpleNamePtr)); +EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void)); +EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *seekFlagPtr)); +EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( + Tcl_Command command)); +EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name, + Tcl_DString *bufferPtr)); +EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int flags)); +EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName, + Tcl_DString *bufPtr)); +EXTERN int TclHasSockets _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclHideUnsafeCommands _ANSI_ARGS_(( + Tcl_Interp *interp)); +EXTERN int TclInExit _ANSI_ARGS_((void)); +EXTERN Tcl_Obj * TclIncrElementOfIndexedArray _ANSI_ARGS_(( + Tcl_Interp *interp, int localIndex, + Tcl_Obj *elemPtr, long incrAmount)); +EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_(( + Tcl_Interp *interp, int localIndex, + long incrAmount)); +EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + long incrAmount, int part1NotParsed)); +EXTERN void TclInitCompiledLocals _ANSI_ARGS_(( + Tcl_Interp *interp, CallFrame *framePtr, + Namespace *nsPtr)); +EXTERN void TclInitNamespaces _ANSI_ARGS_((void)); +EXTERN int TclInterpInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int flags)); +EXTERN int TclInvokeObjectCommand _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +EXTERN int TclInvokeStringCommand _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); +EXTERN int TclLoadFile _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *sym1, char *sym2, + Tcl_PackageInitProc **proc1Ptr, + Tcl_PackageInitProc **proc2Ptr)); +EXTERN int TclLooksLikeInt _ANSI_ARGS_((char *p)); +EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, char *msg, + int createPart1, int createPart2, + Var **arrayPtrPtr)); +EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *dirPtr, + char *pattern, char *tail)); +EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); +EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr)); +EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr)); +EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], int flags)); +EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], int flags)); +EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_(( + TclOpenFileChannelProc_ *proc)); +EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( + TclOpenFileChannelProc_ *proc)); +EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); + +/* + * On a Mac, we can exit gracefully if the stack gets too small. + */ + +#ifdef MAC_TCL +EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); +#else +#define TclpCheckStackSpace() (1) +#endif + +EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file)); +EXTERN int TclpCopyFile _ANSI_ARGS_((char *source, char *dest)); +EXTERN int TclpCopyDirectory _ANSI_ARGS_((char *source, + char *dest, Tcl_DString *errorPtr)); +EXTERN Tcl_Channel TclpCreateCommandChannel _ANSI_ARGS_(( + TclFile readFile, TclFile writeFile, + TclFile errorFile, int numPids, Tcl_Pid *pidPtr)); +EXTERN int TclpCreateDirectory _ANSI_ARGS_((char *path)); +EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile *readPipe, + TclFile *writePipe)); +EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, TclFile inputFile, + TclFile outputFile, TclFile errorFile, + Tcl_Pid *pidPtr)); +EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((char *contents, + Tcl_DString *namePtr)); +EXTERN int TclpDeleteFile _ANSI_ARGS_((char *path)); +EXTERN void TclpFinalize _ANSI_ARGS_((void)); +EXTERN void TclpFree _ANSI_ARGS_((char *ptr)); +EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void)); +EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void)); +EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time)); +EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time)); +EXTERN char * TclpGetTZName _ANSI_ARGS_((void)); +EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel, + int direction)); +EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char *fname, int mode)); +EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *modeString, + int permissions)); +EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, + unsigned int size)); +EXTERN int TclpRemoveDirectory _ANSI_ARGS_((char *path, + int recursive, Tcl_DString *errorPtr)); +EXTERN int TclpRenameFile _ANSI_ARGS_((char *source, char *dest)); +#ifndef TclpSysAlloc +EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); +#endif +#ifndef TclpSysFree +EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr)); +#endif +#ifndef TclpSysRealloc +EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp, + unsigned int size)); +#endif +EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char **termPtr, ParseValue *pvPtr)); +EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int flags, char **termPtr, + ParseValue *pvPtr)); +EXTERN int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int termChar, int flags, + char **termPtr, ParseValue *pvPtr)); +EXTERN void TclPlatformExit _ANSI_ARGS_((int status)); +EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *cmdInterp, Tcl_Command cmd)); +EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc *procPtr)); +EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp, + Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, + CONST char *description, CONST char *procName)); +EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData)); +EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *oldName, char *newName)) ; +EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_(( + Tcl_Interp *interp, Command *newCmdPtr)); +EXTERN int TclServiceIdle _ANSI_ARGS_((void)); +EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_(( + Tcl_Interp *interp, int localIndex, + Tcl_Obj *elemPtr, Tcl_Obj *objPtr, + int leaveErrorMsg)); +EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, + int localIndex, Tcl_Obj *objPtr, + int leaveErrorMsg)); +EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char *string)); +EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *proto, int *portPtr)); +EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, + int size)); +EXTERN int TclStat _ANSI_ARGS_((CONST char *path, + TclStat_ *buf)); +EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc)); +EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc)); +EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr)); +EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclTestChannelEventCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); +EXTERN char * TclWordEnd _ANSI_ARGS_((char *start, char *lastChar, + int nested, int *semiPtr)); + +/* + *---------------------------------------------------------------- + * Command procedures in the generic core: + *---------------------------------------------------------------- + */ + +EXTERN int Tcl_AfterObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_AppendObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_BinaryObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CaseObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_CdObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ClockObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ErrorObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_EvalObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FcopyObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_FileObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_FileEventCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FlushObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ForeachObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_FormatObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_GetsObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_GlobalObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_InfoObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_InterpObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_JoinObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_LappendObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_LindexObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_LinsertObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_LlengthObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ListObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_LoadCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LrangeObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_LreplaceObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_LsearchObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_LsortObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_OpenCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PackageCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PidObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ProcObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_PutsObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_PwdCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ReadObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_RegexpCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RegsubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RenameObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ReturnObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ScanCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SplitObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_SocketCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SourceObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_StringObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_SubstCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SwitchObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_TellCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_TimeObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UnsetObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_UpdateCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UplevelObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_UpvarObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_VariableObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_VwaitCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------- + * Command procedures found only in the Mac version of the core: + *---------------------------------------------------------------- + */ + +#ifdef MAC_TCL +EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +#endif + +/* + *---------------------------------------------------------------- + * Compilation procedures for commands in the generic core: + *---------------------------------------------------------------- + */ + +EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int compileFlags, + struct CompileEnv *compileEnvPtr)); +EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int compileFlags, + struct CompileEnv *compileEnvPtr)); +EXTERN int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int compileFlags, + struct CompileEnv *compileEnvPtr)); +EXTERN int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int compileFlags, + struct CompileEnv *compileEnvPtr)); +EXTERN int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int compileFlags, + struct CompileEnv *compileEnvPtr)); +EXTERN int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int compileFlags, + struct CompileEnv *compileEnvPtr)); +EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int compileFlags, + struct CompileEnv *compileEnvPtr)); +EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int compileFlags, + struct CompileEnv *compileEnvPtr)); +EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int compileFlags, + struct CompileEnv *compileEnvPtr)); +EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *lastChar, int compileFlags, + struct CompileEnv *compileEnvPtr)); + +/* + *---------------------------------------------------------------- + * Macros used by the Tcl core to create and release Tcl objects. + * TclNewObj(objPtr) creates a new object denoting an empty string. + * TclDecrRefCount(objPtr) decrements the object's reference count, + * and frees the object if its reference count is zero. + * These macros are inline versions of Tcl_NewObj() and + * Tcl_DecrRefCount(). Notice that the names differ in not having + * a "_" after the "Tcl". Notice also that these macros reference + * their argument more than once, so you should avoid calling them + * with an expression that is expensive to compute or has + * side effects. The ANSI C "prototypes" for these macros are: + * + * EXTERN void TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr)); + * EXTERN void TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); + *---------------------------------------------------------------- + */ + +#ifdef TCL_COMPILE_STATS +# define TclIncrObjsAllocated() \ + tclObjsAlloced++ +# define TclIncrObjsFreed() \ + tclObjsFreed++ +#else +# define TclIncrObjsAllocated() +# define TclIncrObjsFreed() +#endif /* TCL_COMPILE_STATS */ + +#ifdef TCL_MEM_DEBUG +# define TclNewObj(objPtr) \ + (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->length = 0; \ + (objPtr)->typePtr = NULL; \ + TclIncrObjsAllocated() +# define TclDbNewObj(objPtr, file, line) \ + (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->length = 0; \ + (objPtr)->typePtr = NULL; \ + TclIncrObjsAllocated() +# define TclDecrRefCount(objPtr) \ + if (--(objPtr)->refCount <= 0) { \ + if ((objPtr)->refCount < -1) \ + panic("Reference count for %lx was negative: %s line %d", \ + (objPtr), __FILE__, __LINE__); \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ + ckfree((char *) (objPtr)->bytes); \ + } \ + if (((objPtr)->typePtr != NULL) \ + && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ + (objPtr)->typePtr->freeIntRepProc(objPtr); \ + } \ + ckfree((char *) (objPtr)); \ + TclIncrObjsFreed(); \ + } +#else /* not TCL_MEM_DEBUG */ +# define TclNewObj(objPtr) \ + if (tclFreeObjList == NULL) { \ + TclAllocateFreeObjects(); \ + } \ + (objPtr) = tclFreeObjList; \ + tclFreeObjList = (Tcl_Obj *) \ + tclFreeObjList->internalRep.otherValuePtr; \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->length = 0; \ + (objPtr)->typePtr = NULL; \ + TclIncrObjsAllocated() +# define TclDecrRefCount(objPtr) \ + if (--(objPtr)->refCount <= 0) { \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ + ckfree((char *) (objPtr)->bytes); \ + } \ + if (((objPtr)->typePtr != NULL) \ + && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ + (objPtr)->typePtr->freeIntRepProc(objPtr); \ + } \ + (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ + tclFreeObjList = (objPtr); \ + TclIncrObjsFreed(); \ + } +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to set a Tcl_Obj's string representation + * to a copy of the "len" bytes starting at "bytePtr". This code + * works even if the byte array contains NULLs as long as the length + * is correct. Because "len" is referenced multiple times, it should + * be as simple an expression as possible. The ANSI C "prototype" for + * this macro is: + * + * EXTERN void TclInitStringRep _ANSI_ARGS_((Tcl_Obj *objPtr, + * char *bytePtr, int len)); + *---------------------------------------------------------------- + */ + +#define TclInitStringRep(objPtr, bytePtr, len) \ + if ((len) == 0) { \ + (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->length = 0; \ + } else { \ + (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ + memcpy((VOID *) (objPtr)->bytes, (VOID *) (bytePtr), \ + (unsigned) (len)); \ + (objPtr)->bytes[len] = '\0'; \ + (objPtr)->length = (len); \ + } + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to get the string representation's + * byte array pointer and length from a Tcl_Obj. This is an inline + * version of Tcl_GetStringFromObj(). "lengthPtr" must be the + * address of an integer variable or NULL; If non-NULL, that variable + * will be set to the string rep's length. The macro's expression + * result is the string rep's byte pointer which might be NULL. + * Note that the bytes referenced by this pointer must not be modified + * by the caller. The ANSI C "prototype" for this macro is: + * + * EXTERN char * TclGetStringFromObj _ANSI_ARGS_((Tcl_Obj *objPtr, + * int *lengthPtr)); + *---------------------------------------------------------------- + */ + +#define TclGetStringFromObj(objPtr, lengthPtr) \ + ((objPtr)->bytes? \ + ((lengthPtr)? \ + ((*(lengthPtr) = (objPtr)->length), (objPtr)->bytes) : \ + (objPtr)->bytes) : \ + Tcl_GetStringFromObj((objPtr), (lengthPtr))) + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to reset an interpreter's Tcl object + * result to an unshared empty string object with ref count one. + * This does not clear any error information for the interpreter. + * The ANSI C "prototype" for this macro is: + * + * EXTERN void TclResetObjResult _ANSI_ARGS_((Tcl_Interp *interp)); + *--------------------------------------------------------------- + */ + +#define TclResetObjResult(interp) \ + { \ + register Tcl_Obj *objResultPtr = ((Interp *) interp)->objResultPtr; \ + if (Tcl_IsShared(objResultPtr)) { \ + TclDecrRefCount(objResultPtr); \ + TclNewObj(objResultPtr); \ + Tcl_IncrRefCount(objResultPtr); \ + ((Interp *) interp)->objResultPtr = objResultPtr; \ + } else { \ + if ((objResultPtr->bytes != NULL) \ + && (objResultPtr->bytes != tclEmptyStringRep)) { \ + ckfree((char *) objResultPtr->bytes); \ + } \ + objResultPtr->bytes = tclEmptyStringRep; \ + objResultPtr->length = 0; \ + if ((objResultPtr->typePtr != NULL) \ + && (objResultPtr->typePtr->freeIntRepProc != NULL)) { \ + objResultPtr->typePtr->freeIntRepProc(objResultPtr); \ + } \ + objResultPtr->typePtr = (Tcl_ObjType *) NULL; \ + } \ + } + +/* + *---------------------------------------------------------------- + * Procedures used in conjunction with Tcl namespaces. They are + * defined here instead of in tcl.h since they are not stable yet. + *---------------------------------------------------------------- + */ + +EXTERN void Tcl_AddInterpResolvers _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_ResolveCmdProc *cmdProc, + Tcl_ResolveVarProc *varProc, + Tcl_ResolveCompiledVarProc *compiledVarProc)); +EXTERN int Tcl_AppendExportList _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Namespace *nsPtr, + Tcl_Obj *objPtr)); +EXTERN Tcl_Namespace * Tcl_CreateNamespace _ANSI_ARGS_((Tcl_Interp *interp, + char *name, ClientData clientData, + Tcl_NamespaceDeleteProc *deleteProc)); +EXTERN void Tcl_DeleteNamespace _ANSI_ARGS_(( + Tcl_Namespace *nsPtr)); +EXTERN int Tcl_Export _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Namespace *nsPtr, char *pattern, + int resetListFirst)); +EXTERN Tcl_Command Tcl_FindCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_Namespace *contextNsPtr, + int flags)); +EXTERN Tcl_Namespace * Tcl_FindNamespace _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_Namespace *contextNsPtr, + int flags)); +EXTERN int Tcl_GetInterpResolvers _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_ResolverInfo *resInfo)); +EXTERN int Tcl_GetNamespaceResolvers _ANSI_ARGS_(( + Tcl_Namespace *namespacePtr, + Tcl_ResolverInfo *resInfo)); +EXTERN void Tcl_GetVariableFullName _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Var variable, + Tcl_Obj *objPtr)); +EXTERN Tcl_Var Tcl_FindNamespaceVar _ANSI_ARGS_(( + Tcl_Interp *interp, char *name, + Tcl_Namespace *contextNsPtr, int flags)); +EXTERN int Tcl_ForgetImport _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Namespace *nsPtr, char *pattern)); +EXTERN Tcl_Command Tcl_GetCommandFromObj _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr)); +EXTERN void Tcl_GetCommandFullName _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Command command, + Tcl_Obj *objPtr)); +EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _ANSI_ARGS_(( + Tcl_Interp *interp)); +EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace _ANSI_ARGS_(( + Tcl_Interp *interp)); +EXTERN void Tcl_GetVariableFullName _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Var variable, + Tcl_Obj *objPtr)); +EXTERN int Tcl_Import _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Namespace *nsPtr, char *pattern, + int allowOverwrite)); +EXTERN void Tcl_PopCallFrame _ANSI_ARGS_((Tcl_Interp* interp)); +EXTERN int Tcl_PushCallFrame _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, + int isProcCallFrame)); +EXTERN int Tcl_RemoveInterpResolvers _ANSI_ARGS_(( + Tcl_Interp *interp, char *name)); +EXTERN void Tcl_SetNamespaceResolvers _ANSI_ARGS_(( + Tcl_Namespace *namespacePtr, + Tcl_ResolveCmdProc *cmdProc, + Tcl_ResolveVarProc *varProc, + Tcl_ResolveCompiledVarProc *compiledVarProc)); + +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLIMPORT + +#endif /* _TCLINT */ + diff --git a/tcl/generic/tclInterp.c b/tcl/generic/tclInterp.c new file mode 100644 index 00000000000..b4c0cd5203e --- /dev/null +++ b/tcl/generic/tclInterp.c @@ -0,0 +1,3835 @@ +/* + * tclInterp.c -- + * + * This file implements the "interp" command which allows creation + * and manipulation of Tcl interpreters from within Tcl scripts. + * + * Copyright (c) 1995-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. + * + * RCS: @(#) $Id$ + */ + +#include <stdio.h> +#include "tclInt.h" +#include "tclPort.h" + +/* + * Counter for how many aliases were created (global) + */ + +static int aliasCounter = 0; + +/* + * + * struct Slave: + * + * Used by the "interp" command to record and find information about slave + * interpreters. Maps from a command name in the master to information about + * a slave interpreter, e.g. what aliases are defined in it. + */ + +typedef struct { + Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ + Tcl_HashEntry *slaveEntry; /* Hash entry in masters slave table for + * this slave interpreter. Used to find + * this record, and used when deleting the + * slave interpreter to delete it from the + * masters table. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Tcl_Command interpCmd; /* Interpreter object command. */ + Tcl_HashTable aliasTable; /* Table which maps from names of commands + * in slave interpreter to struct Alias + * defined below. */ +} Slave; + +/* + * struct Alias: + * + * Stores information about an alias. Is stored in the slave interpreter + * and used by the source command to find the target command in the master + * when the source command is invoked. + */ + +typedef struct { + char *aliasName; /* Name of alias command. */ + char *targetName; /* Name of target command in master interp. */ + Tcl_Interp *targetInterp; /* Master interpreter. */ + int objc; /* Count of additional args to pass. */ + Tcl_Obj **objv; /* Actual additional args to pass. */ + Tcl_HashEntry *aliasEntry; /* Entry for the alias hash table in slave. + * This is used by alias deletion to remove + * the alias from the slave interpreter + * alias table. */ + Tcl_HashEntry *targetEntry; /* Entry for target command in master. + * This is used in the master interpreter to + * map back from the target command to aliases + * redirecting to it. Random access to this + * hash table is never required - we are using + * a hash table only for convenience. */ + Tcl_Command slaveCmd; /* Source command in slave interpreter. */ +} Alias; + +/* + * struct Target: + * + * Maps from master interpreter commands back to the source commands in slave + * interpreters. This is needed because aliases can be created between sibling + * interpreters and must be deleted when the target interpreter is deleted. In + * case they would not be deleted the source interpreter would be left with a + * "dangling pointer". One such record is stored in the Master record of the + * master interpreter (in the targetTable hashtable, see below) with the + * master for each alias which directs to a command in the master. These + * records are used to remove the source command for an from a slave if/when + * the master is deleted. + */ + +typedef struct { + Tcl_Command slaveCmd; /* Command for alias in slave interp. */ + Tcl_Interp *slaveInterp; /* Slave Interpreter. */ +} Target; + +/* + * struct Master: + * + * This record is used for two purposes: First, slaveTable (a hashtable) + * maps from names of commands to slave interpreters. This hashtable is + * used to store information about slave interpreters of this interpreter, + * to map over all slaves, etc. The second purpose is to store information + * about all aliases in slaves (or siblings) which direct to target commands + * in this interpreter (using the targetTable hashtable). + * + * NB: the flags field in the interp structure, used with SAFE_INTERP + * mask denotes whether the interpreter is safe or not. Safe + * interpreters have restricted functionality, can only create safe slave + * interpreters and can only load safe extensions. + */ + +typedef struct { + Tcl_HashTable slaveTable; /* Hash table for slave interpreters. + * Maps from command names to Slave records. */ + Tcl_HashTable targetTable; /* Hash table for Target Records. Contains + * all Target records which denote aliases + * from slaves or sibling interpreters that + * direct to commands in this interpreter. This + * table is used to remove dangling pointers + * from the slave (or sibling) interpreters + * when this interpreter is deleted. */ +} Master; + +/* + * Prototypes for local static procedures: + */ + +static int AliasCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *currentInterp, int objc, + Tcl_Obj *CONST objv[])); +static void AliasCmdDeleteProc _ANSI_ARGS_(( + ClientData clientData)); +static int AliasCreationHelper _ANSI_ARGS_((Tcl_Interp *curInterp, + Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, + Master *masterPtr, char *aliasName, + char *targetName, int objc, + Tcl_Obj *CONST objv[])); +static int CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static Tcl_Interp *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, char *slavePath, int safe)); +static int DeleteAlias _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, char *aliasName)); +static int DescribeAlias _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, char *aliasName)); +static int DeleteInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, char *path)); +static Tcl_Interp *GetInterp _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, char *path, + Master **masterPtrPtr)); +static int GetTarget _ANSI_ARGS_((Tcl_Interp *interp, char *path, + char *aliasName)); +static int InterpAliasHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpExistsHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpEvalHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpExposeHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpIsSafeHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpHideHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpInvokeHiddenHelper _ANSI_ARGS_(( + Tcl_Interp *interp, Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpMarkTrustedHelper _ANSI_ARGS_(( + Tcl_Interp *interp, Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpSlavesHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpShareHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpTargetHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int InterpTransferHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); +static int MarkTrusted _ANSI_ARGS_((Tcl_Interp *interp)); +static void MasterRecordDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static int SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, Slave *slavePtr, + int objc, Tcl_Obj *CONST objv[])); +static int SlaveAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, Slave *slavePtr, + int objc, Tcl_Obj *CONST objv[])); +static int SlaveEvalHelper _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, Slave *slavePtr, + int objc, Tcl_Obj *CONST objv[])); +static int SlaveExposeHelper _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, Slave *slavePtr, + int objc, Tcl_Obj *CONST objv[])); +static int SlaveHideHelper _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, Slave *slavePtr, + int objc, Tcl_Obj *CONST objv[])); +static int SlaveHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, Slave *slavePtr, + int objc, Tcl_Obj *CONST objv[])); +static int SlaveIsSafeHelper _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Interp *slaveInterp, + Slave *slavePtr, int objc, Tcl_Obj *CONST objv[])); +static int SlaveInvokeHiddenHelper _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Interp *slaveInterp, + Slave *slavePtr, int objc, Tcl_Obj *CONST objv[])); +static int SlaveMarkTrustedHelper _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, Slave *slavePtr, + int objc, Tcl_Obj *CONST objv[])); +static int SlaveObjectCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static void SlaveObjectDeleteProc _ANSI_ARGS_(( + ClientData clientData)); +static void SlaveRecordDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); + +/* + *---------------------------------------------------------------------- + * + * TclPreventAliasLoop -- + * + * When defining an alias or renaming a command, prevent an alias + * loop from being formed. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * If TCL_ERROR is returned, the function also stores an error message + * in the interpreter's result object. + * + * NOTE: + * This function is public internal (instead of being static to + * this file) because it is also used from TclRenameCommand. + * + *---------------------------------------------------------------------- + */ + +int +TclPreventAliasLoop(interp, cmdInterp, cmd) + Tcl_Interp *interp; /* Interp in which to report errors. */ + Tcl_Interp *cmdInterp; /* Interp in which the command is + * being defined. */ + Tcl_Command cmd; /* Tcl command we are attempting + * to define. */ +{ + Command *cmdPtr = (Command *) cmd; + Alias *aliasPtr, *nextAliasPtr; + Tcl_Command aliasCmd; + Command *aliasCmdPtr; + + /* + * If we are not creating or renaming an alias, then it is + * always OK to create or rename the command. + */ + + if (cmdPtr->objProc != AliasCmd) { + return TCL_OK; + } + + /* + * OK, we are dealing with an alias, so traverse the chain of aliases. + * If we encounter the alias we are defining (or renaming to) any in + * the chain then we have a loop. + */ + + aliasPtr = (Alias *) cmdPtr->objClientData; + nextAliasPtr = aliasPtr; + while (1) { + + /* + * If the target of the next alias in the chain is the same as + * the source alias, we have a loop. + */ + + aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, + nextAliasPtr->targetName, + Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp), + /*flags*/ 0); + if (aliasCmd == (Tcl_Command) NULL) { + return TCL_OK; + } + aliasCmdPtr = (Command *) aliasCmd; + if (aliasCmdPtr == cmdPtr) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot define or rename alias \"", aliasPtr->aliasName, + "\": would create a loop", (char *) NULL); + return TCL_ERROR; + } + + /* + * Otherwise, follow the chain one step further. See if the target + * command is an alias - if so, follow the loop to its target + * command. Otherwise we do not have a loop. + */ + + if (aliasCmdPtr->objProc != AliasCmd) { + return TCL_OK; + } + nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; + } + + /* NOTREACHED */ +} + +/* + *---------------------------------------------------------------------- + * + * MarkTrusted -- + * + * Mark an interpreter as unsafe (i.e. remove the "safe" mark). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Removes the "safe" mark from an interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +MarkTrusted(interp) + Tcl_Interp *interp; /* Interpreter to be marked unsafe. */ +{ + Interp *iPtr = (Interp *) interp; + + iPtr->flags &= ~SAFE_INTERP; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeSafe -- + * + * Makes its argument interpreter contain only functionality that is + * defined to be part of Safe Tcl. Unsafe commands are hidden, the + * env array is unset, and the standard channels are removed. + * + * Results: + * None. + * + * Side effects: + * Hides commands in its argument interpreter, and removes settings + * and channels. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_MakeSafe(interp) + Tcl_Interp *interp; /* Interpreter to be made safe. */ +{ + Tcl_Channel chan; /* Channel to remove from + * safe interpreter. */ + Interp *iPtr = (Interp *) interp; + + TclHideUnsafeCommands(interp); + + iPtr->flags |= SAFE_INTERP; + + /* + * Unsetting variables : (which should not have been set + * in the first place, but...) + */ + + /* + * No env array in a safe slave. + */ + + Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); + + /* + * Remove unsafe parts of tcl_platform + */ + + Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY); + Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY); + Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY); + + /* + * Unset path informations variables + * (the only one remaining is [info nameofexecutable]) + */ + + Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); + Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); + + /* + * Remove the standard channels from the interpreter; safe interpreters + * do not ordinarily have access to stdin, stdout and stderr. + * + * NOTE: These channels are not added to the interpreter by the + * Tcl_CreateInterp call, but may be added later, by another I/O + * operation. We want to ensure that the interpreter does not have + * these channels even if it is being made safe after being used for + * some time.. + */ + + chan = Tcl_GetStdChannel(TCL_STDIN); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetInterp -- + * + * Helper function to find a slave interpreter given a pathname. + * + * Results: + * Returns the slave interpreter known by that name in the calling + * interpreter, or NULL if no interpreter known by that name exists. + * + * Side effects: + * Assigns to the pointer variable passed in, if not NULL. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Interp * +GetInterp(interp, masterPtr, path, masterPtrPtr) + Tcl_Interp *interp; /* Interp. to start search from. */ + Master *masterPtr; /* Its master record. */ + char *path; /* The path (name) of interp. to be found. */ + Master **masterPtrPtr; /* (Return) its master record. */ +{ + Tcl_HashEntry *hPtr; /* Search element. */ + Slave *slavePtr; /* Interim slave record. */ + char **argv; /* Split-up path (name) for interp to find. */ + int argc, i; /* Loop indices. */ + Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ + + if (masterPtrPtr != (Master **) NULL) { + *masterPtrPtr = masterPtr; + } + + if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) { + return (Tcl_Interp *) NULL; + } + + for (searchInterp = interp, i = 0; i < argc; i++) { + + hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]); + if (hPtr == (Tcl_HashEntry *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + searchInterp = slavePtr->slaveInterp; + if (searchInterp == (Tcl_Interp *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + masterPtr = (Master *) Tcl_GetAssocData(searchInterp, + "tclMasterRecord", NULL); + if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr; + if (masterPtr == (Master *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + } + ckfree((char *) argv); + return searchInterp; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSlave -- + * + * Helper function to do the actual work of creating a slave interp + * and new object command. Also optionally makes the new slave + * interpreter "safe". + * + * Results: + * Returns the new Tcl_Interp * if successful or NULL if not. If failed, + * the result of the invoking interpreter contains an error message. + * + * Side effects: + * Creates a new slave interpreter and a new object command. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Interp * +CreateSlave(interp, masterPtr, slavePath, safe) + Tcl_Interp *interp; /* Interp. to start search from. */ + Master *masterPtr; /* Master record. */ + char *slavePath; /* Path (name) of slave to create. */ + int safe; /* Should we make it "safe"? */ +{ + Tcl_Interp *slaveInterp; /* Ptr to slave interpreter. */ + Tcl_Interp *masterInterp; /* Ptr to master interp for slave. */ + Slave *slavePtr; /* Slave record. */ + Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ + int new; /* Indicates whether new entry. */ + int argc; /* Count of elements in slavePath. */ + char **argv; /* Elements in slavePath. */ + char *masterPath; /* Path to its master. */ + + if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) { + return (Tcl_Interp *) NULL; + } + + if (argc < 2) { + masterInterp = interp; + if (argc == 1) { + slavePath = argv[0]; + } + } else { + masterPath = Tcl_Merge(argc-1, argv); + masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter named \"", masterPath, + "\" not found", (char *) NULL); + ckfree((char *) argv); + ckfree((char *) masterPath); + return (Tcl_Interp *) NULL; + } + ckfree((char *) masterPath); + slavePath = argv[argc-1]; + if (!safe) { + safe = Tcl_IsSafe(masterInterp); + } + } + hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new); + if (new == 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter named \"", slavePath, + "\" already exists, cannot create", (char *) NULL); + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + slaveInterp = Tcl_CreateInterp(); + if (slaveInterp == (Tcl_Interp *) NULL) { + panic("CreateSlave: out of memory while creating a new interpreter"); + } + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); + slavePtr->masterInterp = masterInterp; + slavePtr->slaveEntry = hPtr; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, slavePath, + SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc); + Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); + (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", + SlaveRecordDeleteProc, (ClientData) slavePtr); + Tcl_SetHashValue(hPtr, (ClientData) slavePtr); + Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + + /* + * Inherit the recursion limit. + */ + ((Interp *)slaveInterp)->maxNestingDepth = + ((Interp *)masterInterp)->maxNestingDepth ; + + if (safe) { + if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { + goto error; + } + } else { + if (Tcl_Init(slaveInterp) == TCL_ERROR) { + goto error; + } + } + + ckfree((char *) argv); + return slaveInterp; + +error: + + Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *) + NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + + Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); + Tcl_ResetResult(slaveInterp); + + (void) Tcl_DeleteCommand(masterInterp, slavePath); + + ckfree((char *) argv); + return (Tcl_Interp *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * CreateInterpObject - + * + * Helper function to do the actual work of creating a new interpreter + * and an object command. + * + * Results: + * A Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +CreateInterpObject(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Invoking interpreter. */ + Master *masterPtr; /* Master record for same. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* with alias. */ +{ + int safe; /* Create a safe interpreter? */ + int moreFlags; /* Expecting more flag args? */ + char *string; /* Local pointer to object string. */ + char *slavePath; /* Name of slave. */ + char localSlaveName[200]; /* Local area for creating names. */ + int i; /* Loop counter. */ + int len; /* Length of option argument. */ + static int interpCounter = 0; /* Unique id for created names. */ + + moreFlags = 1; + slavePath = NULL; + safe = Tcl_IsSafe(interp); + + if ((objc < 2) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); + return TCL_ERROR; + } + for (i = 2; i < objc; i++) { + string = Tcl_GetStringFromObj(objv[i], &len); + if ((string[0] == '-') && (moreFlags != 0)) { + if ((string[1] == 's') && + (strncmp(string, "-safe", (size_t) len) == 0) && + (len > 1)){ + safe = 1; + } else if ((strncmp(string, "--", (size_t) len) == 0) && + (len > 1)) { + moreFlags = 0; + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", string, "\": should be -safe", + (char *) NULL); + return TCL_ERROR; + } + } else { + slavePath = string; + } + } + if (slavePath == (char *) NULL) { + + /* + * Create an anonymous interpreter -- we choose its name and + * the name of the command. We check that the command name that + * we use for the interpreter does not collide with an existing + * command in the master interpreter. + */ + + while (1) { + Tcl_CmdInfo cmdInfo; + + sprintf(localSlaveName, "interp%d", interpCounter); + interpCounter++; + if (!(Tcl_GetCommandInfo(interp, localSlaveName, &cmdInfo))) { + break; + } + } + slavePath = localSlaveName; + } + if (CreateSlave(interp, masterPtr, slavePath, safe) != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(slavePath, -1)); + return TCL_OK; + } else { + /* + * CreateSlave already set the result if there was an error, + * so we do not do it here. + */ + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * DeleteOneInterpObject -- + * + * Helper function for DeleteInterpObject. It deals with deleting one + * interpreter at a time. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes an interpreter and its interpreter object command. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteOneInterpObject(interp, masterPtr, path) + Tcl_Interp *interp; /* Interpreter for reporting errors. */ + Master *masterPtr; /* Interim storage for master record.*/ + char *path; /* Path of interpreter to delete. */ +{ + Slave *slavePtr; /* Interim storage for slave record. */ + Tcl_Interp *masterInterp; /* Master of interp. to delete. */ + Tcl_HashEntry *hPtr; /* Search element. */ + int localArgc; /* Local copy of count of elements in + * path (name) of interp. to delete. */ + char **localArgv; /* Local copy of path. */ + char *slaveName; /* Last component in path. */ + char *masterPath; /* One-before-last component in path.*/ + + if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad interpreter path \"", path, "\"", (char *) NULL); + return TCL_ERROR; + } + if (localArgc < 2) { + masterInterp = interp; + if (localArgc == 0) { + slaveName = ""; + } else { + slaveName = localArgv[0]; + } + } else { + masterPath = Tcl_Merge(localArgc-1, localArgv); + masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter named \"", masterPath, "\" not found", + (char *) NULL); + ckfree((char *) localArgv); + ckfree((char *) masterPath); + return TCL_ERROR; + } + ckfree((char *) masterPath); + slaveName = localArgv[localArgc-1]; + } + hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName); + if (hPtr == (Tcl_HashEntry *) NULL) { + ckfree((char *) localArgv); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter named \"", path, "\" not found", (char *) NULL); + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + if (Tcl_DeleteCommandFromToken(masterInterp, slavePtr->interpCmd) != 0) { + ckfree((char *) localArgv); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter named \"", path, "\" not found", (char *) NULL); + return TCL_ERROR; + } + ckfree((char *) localArgv); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteInterpObject -- + * + * Helper function to do the work of deleting zero or more + * interpreters and their interpreter object commands. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes interpreters and their interpreter object command. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteInterpObject(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Interpreter start search from. */ + Master *masterPtr; /* Interim storage for master record.*/ + int objc; /* Number of arguments in vector. */ + Tcl_Obj *CONST objv[]; /* with alias. */ +{ + int i; + int len; + + for (i = 2; i < objc; i++) { + if (DeleteOneInterpObject(interp, masterPtr, + Tcl_GetStringFromObj(objv[i], &len)) + != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AliasCreationHelper -- + * + * Helper function to do the work to actually create an alias or + * delete an alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * An alias command is created and entered into the alias table + * for the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr, + aliasName, targetName, objc, objv) + Tcl_Interp *curInterp; /* Interp that invoked this proc. */ + Tcl_Interp *slaveInterp; /* Interp where alias cmd will live + * or from which alias will be + * deleted. */ + Tcl_Interp *masterInterp; /* Interp where target cmd will be. */ + Master *masterPtr; /* Master record for target interp. */ + char *aliasName; /* Name of alias cmd. */ + char *targetName; /* Name of target cmd. */ + int objc; /* Additional arguments to store */ + Tcl_Obj *CONST objv[]; /* with alias. */ +{ + Alias *aliasPtr; /* Storage for alias data. */ + Alias *tmpAliasPtr; /* Temp storage for alias to delete. */ + Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ + int i; /* Loop index. */ + int new; /* Is it a new hash entry? */ + Target *targetPtr; /* Maps from target command in master + * to source command in slave. */ + Slave *slavePtr; /* Maps from source command in slave + * to target command in master. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); + + /* + * Slave record should be always present because it is created when + * the interpreter is created. + */ + + if (slavePtr == (Slave *) NULL) { + panic("AliasCreationHelper: could not find slave record"); + } + + if ((targetName == (char *) NULL) || (targetName[0] == '\0')) { + if (objc != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(curInterp), + "malformed command: should be", + " \"alias ", aliasName, " {}\"", (char *) NULL); + return TCL_ERROR; + } + + return DeleteAlias(curInterp, slaveInterp, aliasName); + } + + aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias)); + aliasPtr->aliasName = (char *) ckalloc((unsigned) strlen(aliasName)+1); + aliasPtr->targetName = (char *) ckalloc((unsigned) strlen(targetName)+1); + strcpy(aliasPtr->aliasName, aliasName); + strcpy(aliasPtr->targetName, targetName); + aliasPtr->targetInterp = masterInterp; + + aliasPtr->objv = NULL; + aliasPtr->objc = objc; + + if (aliasPtr->objc > 0) { + aliasPtr->objv = + (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * + aliasPtr->objc); + for (i = 0; i < objc; i++) { + aliasPtr->objv[i] = objv[i]; + Tcl_IncrRefCount(objv[i]); + } + } + + aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, aliasName, + AliasCmd, (ClientData) aliasPtr, AliasCmdDeleteProc); + + if (TclPreventAliasLoop(curInterp, slaveInterp, + aliasPtr->slaveCmd) != TCL_OK) { + + /* + * Found an alias loop! The last call to Tcl_CreateObjCommand + * made the alias point to itself. Delete the command and + * its alias record. Be careful to wipe out its client data + * first, so the command doesn't try to delete itself. + */ + + Command *cmdPtr = (Command*) aliasPtr->slaveCmd; + cmdPtr->clientData = NULL; + cmdPtr->deleteProc = NULL; + cmdPtr->deleteData = NULL; + Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); + + for (i = 0; i < objc; i++) { + Tcl_DecrRefCount(aliasPtr->objv[i]); + } + if (aliasPtr->objv != (Tcl_Obj *CONST *) NULL) { + ckfree((char *) aliasPtr->objv); + } + ckfree(aliasPtr->aliasName); + ckfree(aliasPtr->targetName); + ckfree((char *) aliasPtr); + + /* + * The result was already set by TclPreventAliasLoop. + */ + + return TCL_ERROR; + } + + /* + * Make an entry in the alias table. If it already exists delete + * the alias command. Then retry. + */ + + do { + hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new); + if (!new) { + tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + (void) Tcl_DeleteCommandFromToken(slaveInterp, + tmpAliasPtr->slaveCmd); + + /* + * The hash entry should be deleted by the Tcl_DeleteCommand + * above, in its command deletion callback (most likely this + * will be AliasCmdDeleteProc, which does the deletion). + */ + } + } while (new == 0); + aliasPtr->aliasEntry = hPtr; + Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); + + /* + * Create the new command. We must do it after deleting any old command, + * because the alias may be pointing at a renamed alias, as in: + * + * interp alias {} foo {} bar # Create an alias "foo" + * rename foo zop # Now rename the alias + * interp alias {} foo {} zop # Now recreate "foo"... + */ + + targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); + targetPtr->slaveCmd = aliasPtr->slaveCmd; + targetPtr->slaveInterp = slaveInterp; + + do { + hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable), + (char *) aliasCounter, &new); + aliasCounter++; + } while (new == 0); + + Tcl_SetHashValue(hPtr, (ClientData) targetPtr); + + aliasPtr->targetEntry = hPtr; + + /* + * Make sure we clear out the object result when setting the string + * result. + */ + + Tcl_SetObjResult(curInterp, Tcl_NewStringObj(aliasPtr->aliasName, -1)); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InterpAliasesHelper -- + * + * Computes a list of aliases defined in an interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +InterpAliasesHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Invoking interpreter. */ + Master *masterPtr; /* Master record for current interp. */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* Actual arguments. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + Slave *slavePtr; /* Record for slave interp. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Tcl_HashSearch hSearch; /* Iteration variable. */ + int len; /* Dummy length variable. */ + Tcl_Obj *listObjPtr, *elemObjPtr; /* Local object pointers. */ + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); + return TCL_ERROR; + } + if (objc == 3) { + slaveInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + } else { + slaveInterp = interp; + } + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, + "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + return TCL_OK; + } + + /* + * Build a list to return the aliases: + */ + + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + + elemObjPtr = Tcl_NewStringObj( + Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr), -1); + Tcl_ListObjAppendElement(interp, listObjPtr, elemObjPtr); + } + Tcl_SetObjResult(interp, listObjPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InterpAliasHelper - + * + * Handles the different forms of the "interp alias" command: + * - interp alias slavePath aliasName + * Describes an alias. + * - interp alias slavePath aliasName {} + * Deletes an alias. + * - interp alias slavePath srcCmd masterPath targetCmd args... + * Creates an alias. + * + * Results: + * A Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +InterpAliasHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for current interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Interp *slaveInterp, /* Interpreters used when */ + *masterInterp; /* creating an alias btn siblings. */ + Master *masterMasterPtr; /* Master record for master interp. */ + int len; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "slavePath slaveCmd masterPath masterCmd ?args ..?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not find interpreter \"", + Tcl_GetStringFromObj(objv[2], &len), "\"", + (char *) NULL); + return TCL_ERROR; + } + if (objc == 4) { + return DescribeAlias(interp, slaveInterp, + Tcl_GetStringFromObj(objv[3], &len)); + } + if (objc == 5 && strcmp(Tcl_GetStringFromObj(objv[4], &len), "") == 0) { + return DeleteAlias(interp, slaveInterp, + Tcl_GetStringFromObj(objv[3], &len)); + } + if (objc < 6) { + Tcl_WrongNumArgs(interp, 2, objv, + "slavePath slaveCmd masterPath masterCmd ?args ..?"); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[4], &len), &masterMasterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not find interpreter \"", + Tcl_GetStringFromObj(objv[4], &len), "\"", (char *) NULL); + return TCL_ERROR; + } + return AliasCreationHelper(interp, slaveInterp, masterInterp, + masterMasterPtr, Tcl_GetStringFromObj(objv[3], &len), + Tcl_GetStringFromObj(objv[5], &len), + objc-6, objv+6); +} + +/* + *---------------------------------------------------------------------- + * + * InterpExistsHelper -- + * + * Computes whether a named interpreter exists or not. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +InterpExistsHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for current interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Obj *objPtr; + int len; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); + return TCL_ERROR; + } + if (objc == 3) { + if (GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), NULL) == + (Tcl_Interp *) NULL) { + objPtr = Tcl_NewIntObj(0); + } else { + objPtr = Tcl_NewIntObj(1); + } + } else { + objPtr = Tcl_NewIntObj(1); + } + Tcl_SetObjResult(interp, objPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InterpEvalHelper -- + * + * Helper function to handle all the details of evaluating a + * command in another interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Whatever the command itself does. + * + *---------------------------------------------------------------------- + */ + +static int +InterpEvalHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for current interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + Interp *iPtr; /* Internal data type for slave. */ + int len; /* Dummy length variable. */ + int result; + Tcl_Obj *namePtr, *objPtr; /* Local object pointer. */ + char *string; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter named \"", Tcl_GetStringFromObj(objv[2], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + objPtr = Tcl_ConcatObj(objc-3, objv+3); + Tcl_IncrRefCount(objPtr); + + Tcl_Preserve((ClientData) slaveInterp); + result = Tcl_EvalObj(slaveInterp, objPtr); + + Tcl_DecrRefCount(objPtr); + + /* + * Now make the result and any error information accessible. We + * have to be careful because the slave interpreter and the current + * interpreter can be the same - do not destroy the result.. This + * can happen if an interpreter contains an alias which is directed + * at a target command in the same interpreter. + */ + + if (interp != slaveInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from + * the target interpreter back to our interpreter. + */ + + iPtr = (Interp *) slaveInterp; + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_AddErrorInfo(slaveInterp, ""); + } + iPtr->flags &= (~(ERR_ALREADY_LOGGED)); + + Tcl_ResetResult(interp); + namePtr = Tcl_NewStringObj("errorInfo", -1); + objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, + (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); + string = Tcl_GetStringFromObj(objPtr, &len); + Tcl_AddObjErrorInfo(interp, string, len); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) + NULL, TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(namePtr); + } + + /* + * Move the result object from one interpreter to the + * other. + */ + + Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); + Tcl_ResetResult(slaveInterp); + + } + Tcl_Release((ClientData) slaveInterp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * InterpExposeHelper -- + * + * Helper function to handle the details of exposing a command in + * another interpreter. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Exposes a command. From now on the command can be called by scripts + * in the interpreter in which it was exposed. + * + *---------------------------------------------------------------------- + */ + +static int +InterpExposeHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for current interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + int len; /* Dummy length variable. */ + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, + "path hiddenCmdName ?cmdName?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "permission denied: safe interpreter cannot expose commands", + (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), &masterPtr); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_ExposeCommand(slaveInterp, + Tcl_GetStringFromObj(objv[3], &len), + (objc == 5 ? + Tcl_GetStringFromObj(objv[4], &len) : + Tcl_GetStringFromObj(objv[3], &len))) + == TCL_ERROR) { + if (interp != slaveInterp) { + Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); + Tcl_ResetResult(slaveInterp); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InterpHideHelper -- + * + * Helper function that handles the details of hiding a command in + * another interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Hides a command. From now on the command cannot be called by + * scripts in that interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +InterpHideHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + int len; /* Dummy length variable. */ + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, + "path cmdName ?hiddenCmdName?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "permission denied: safe interpreter cannot hide commands", + (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), &masterPtr); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[3], &len), + (objc == 5 ? + Tcl_GetStringFromObj(objv[4], &len) : + Tcl_GetStringFromObj(objv[3], &len))) + == TCL_ERROR) { + if (interp != slaveInterp) { + Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); + Tcl_ResetResult(slaveInterp); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InterpHiddenHelper -- + * + * Computes the list of hidden commands in a named interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +InterpHiddenHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + int len; + Tcl_HashTable *hTblPtr; /* Hidden command table. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Tcl_HashSearch hSearch; /* Iteration variable. */ + Tcl_Obj *listObjPtr; /* Local object pointer. */ + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); + return TCL_ERROR; + } + if (objc == 3) { + slaveInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), + &masterPtr); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + } else { + slaveInterp = interp; + } + + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp, + "tclHiddenCmds", NULL); + if (hTblPtr != (Tcl_HashTable *) NULL) { + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); + } + } + Tcl_SetObjResult(interp, listObjPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InterpInvokeHiddenHelper -- + * + * Helper routine to handle the details of invoking a hidden + * command in another interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Whatever the hidden command does. + * + *---------------------------------------------------------------------- + */ + +static int +InterpInvokeHiddenHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int doGlobal = 0; + int len; + int result; + Tcl_Obj *namePtr, *objPtr; + Tcl_Interp *slaveInterp; + Interp *iPtr; + char *string; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "path ?-global? cmd ?arg ..?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "not allowed to invoke hidden commands from safe interpreter", + (char *) NULL); + return TCL_ERROR; + } + if (strcmp(Tcl_GetStringFromObj(objv[3], &len), "-global") == 0) { + doGlobal = 1; + if (objc < 5) { + Tcl_WrongNumArgs(interp, 2, objv, + "path ?-global? cmd ?arg ..?"); + return TCL_ERROR; + } + } + slaveInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), &masterPtr); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) slaveInterp); + if (doGlobal) { + result = TclObjInvokeGlobal(slaveInterp, objc-4, objv+4, + TCL_INVOKE_HIDDEN); + } else { + result = TclObjInvoke(slaveInterp, objc-3, objv+3, TCL_INVOKE_HIDDEN); + } + + /* + * Now make the result and any error information accessible. We + * have to be careful because the slave interpreter and the current + * interpreter can be the same - do not destroy the result.. This + * can happen if an interpreter contains an alias which is directed + * at a target command in the same interpreter. + */ + + if (interp != slaveInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from + * the target interpreter back to our interpreter. + */ + + iPtr = (Interp *) slaveInterp; + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_AddErrorInfo(slaveInterp, ""); + } + iPtr->flags &= (~(ERR_ALREADY_LOGGED)); + + Tcl_ResetResult(interp); + namePtr = Tcl_NewStringObj("errorInfo", -1); + objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, + (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(namePtr); + string = Tcl_GetStringFromObj(objPtr, &len); + Tcl_AddObjErrorInfo(interp, string, len); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) + NULL, TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + } + + /* + * Move the result object from the slave to the master. + */ + + Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); + Tcl_ResetResult(slaveInterp); + } + Tcl_Release((ClientData) slaveInterp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * InterpMarkTrustedHelper -- + * + * Helper function to handle the details of marking another + * interpreter as trusted (unsafe). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Henceforth the hard-wired checks for safety will not prevent + * this interpreter from performing certain operations. + * + *---------------------------------------------------------------------- + */ + +static int +InterpMarkTrustedHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + int len; /* Dummy length variable. */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", Tcl_GetStringFromObj(objv[0], &len), + " marktrusted\" can only", + " be invoked from a trusted interpreter", + (char *) NULL); + return TCL_ERROR; + } + + slaveInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), &masterPtr); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + return MarkTrusted(slaveInterp); +} + +/* + *---------------------------------------------------------------------- + * + * InterpIsSafeHelper -- + * + * Computes whether a named interpreter is safe. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +InterpIsSafeHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + int len; /* Dummy length variable. */ + Tcl_Obj *objPtr; /* Local object pointer. */ + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); + return TCL_ERROR; + } + if (objc == 3) { + slaveInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), &masterPtr); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", + Tcl_GetStringFromObj(objv[2], &len), "\" not found", + (char *) NULL); + return TCL_ERROR; + } + objPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp)); + } else { + objPtr = Tcl_NewIntObj(Tcl_IsSafe(interp)); + } + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InterpSlavesHelper -- + * + * Computes a list of slave interpreters of a named interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +InterpSlavesHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int len; + Tcl_HashEntry *hPtr; /* Search variable. */ + Tcl_HashSearch hSearch; /* Iteration variable. */ + Tcl_Obj *listObjPtr; /* Local object pointers. */ + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); + return TCL_ERROR; + } + if (objc == 3) { + if (GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), &masterPtr) == + (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + } + + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj( + Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr), -1)); + } + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InterpShareHelper -- + * + * Helper function to handle the details of sharing a channel between + * interpreters. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * After this call the named channel will be shared between the + * interpreters named in the arguments. + * + *---------------------------------------------------------------------- + */ + +static int +InterpShareHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* Its master. */ + int len; + Tcl_Channel chan; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), NULL); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[4], &len), NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", Tcl_GetStringFromObj(objv[4], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, Tcl_GetStringFromObj(objv[3], &len), + NULL); + if (chan == (Tcl_Channel) NULL) { + if (interp != masterInterp) { + Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InterpTargetHelper -- + * + * Helper function to compute the target of an alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +InterpTargetHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int len; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path alias"); + return TCL_ERROR; + } + return GetTarget(interp, + Tcl_GetStringFromObj(objv[2], &len), + Tcl_GetStringFromObj(objv[3], &len)); +} + +/* + *---------------------------------------------------------------------- + * + * InterpTransferHelper -- + * + * Helper function to handle the details of transferring ownership + * of a channel between interpreters. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * After the call, the named channel will be registered in the target + * interpreter and no longer available for use in the source interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +InterpTransferHelper(interp, masterPtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Master *masterPtr; /* Master record for interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* Its master. */ + int len; + Tcl_Channel chan; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, + "srcPath channelId destPath"); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[2], &len), NULL); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, + Tcl_GetStringFromObj(objv[4], &len), NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter \"", Tcl_GetStringFromObj(objv[4], &len), + "\" not found", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, + Tcl_GetStringFromObj(objv[3], &len), NULL); + if (chan == (Tcl_Channel) NULL) { + if (interp != masterInterp) { + + /* + * After fixing objresult, this code will change to: + * Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); + */ + + Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { + if (interp != masterInterp) { + Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DescribeAlias -- + * + * Sets the interpreter's result object to a Tcl list describing + * the given alias in the given interpreter: its target command + * and the additional arguments to prepend to any invocation + * of the alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DescribeAlias(interp, slaveInterp, aliasName) + Tcl_Interp *interp; /* Interpreter for result & errors. */ + Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ + char *aliasName; /* Name of alias to describe. */ +{ + Slave *slavePtr; /* Slave interp slave record. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Alias *aliasPtr; /* Structure describing alias. */ + int i; /* Loop variable. */ + Tcl_Obj *listObjPtr; /* Local object pointer. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + + /* + * The slave record should always be present because it is created + * by Tcl_CreateInterp. + */ + + if (slavePtr == (Slave *) NULL) { + panic("DescribeAlias: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + return TCL_OK; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(aliasPtr->targetName, -1)); + for (i = 0; i < aliasPtr->objc; i++) { + Tcl_ListObjAppendElement(interp, listObjPtr, aliasPtr->objv[i]); + } + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteAlias -- + * + * Deletes the given alias from the slave interpreter given. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes the alias from the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteAlias(interp, slaveInterp, aliasName) + Tcl_Interp *interp; /* Interpreter for result and errors. */ + Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ + char *aliasName; /* Name of alias to delete. */ +{ + Slave *slavePtr; /* Slave record for slave interpreter. */ + Alias *aliasPtr; /* Points at alias structure to delete. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + char *tmpPtr, *namePtr; /* Local pointers to name of command to + * be deleted. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "alias \"", aliasName, "\" not found", (char *) NULL); + return TCL_ERROR; + } + + /* + * Get the alias from the alias table, then delete the command. The + * deleteProc on the alias command will take care of removing the entry + * from the alias table. + */ + + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "alias \"", aliasName, "\" not found", (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + + /* + * Get a copy of the real name of the command -- it might have + * been renamed, and we want to delete the renamed command, not + * the current command (if any) by the name of the original alias. + * We need the local copy because the name may get smashed when the + * command to delete is exposed, if it was hidden. + */ + + tmpPtr = Tcl_GetCommandName(slaveInterp, aliasPtr->slaveCmd); + namePtr = (char *) ckalloc((unsigned) strlen(tmpPtr) + 1); + strcpy(namePtr, tmpPtr); + + /* + * NOTE: The deleteProc for this command will delete the + * alias from the hash table. The deleteProc will also + * delete the target information from the master interpreter + * target table. + */ + + if (Tcl_DeleteCommand(slaveInterp, namePtr) != 0) { + if (Tcl_ExposeCommand(slaveInterp, namePtr, namePtr) != TCL_OK) { + panic("DeleteAlias: did not find alias to be deleted"); + } + if (Tcl_DeleteCommand(slaveInterp, namePtr) != 0) { + panic("DeleteAlias: did not find alias to be deleted"); + } + } + ckfree(namePtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetInterpPath -- + * + * Sets the result of the asking interpreter to a proper Tcl list + * containing the names of interpreters between the asking and + * target interpreters. The target interpreter must be either the + * same as the asking interpreter or one of its slaves (including + * recursively). + * + * Results: + * TCL_OK if the target interpreter is the same as, or a descendant + * of, the asking interpreter; TCL_ERROR else. This way one can + * distinguish between the case where the asking and target interps + * are the same (an empty list is the result, and TCL_OK is returned) + * and when the target is not a descendant of the asking interpreter + * (in which case the Tcl result is an error message and the function + * returns TCL_ERROR). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetInterpPath(askingInterp, targetInterp) + Tcl_Interp *askingInterp; /* Interpreter to start search from. */ + Tcl_Interp *targetInterp; /* Interpreter to find. */ +{ + Master *masterPtr; /* Interim storage for Master record. */ + Slave *slavePtr; /* Interim storage for Slave record. */ + + if (targetInterp == askingInterp) { + return TCL_OK; + } + if (targetInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + return TCL_ERROR; + } + if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) { + + /* + * The result of askingInterp was set by recursive call. + */ + + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(slavePtr->masterInterp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_GetInterpPath: could not find master record"); + } + Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&(masterPtr->slaveTable), + slavePtr->slaveEntry)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetTarget -- + * + * Sets the result of the invoking interpreter to a path name for + * the target interpreter of an alias in one of the slaves. + * + * Results: + * TCL_OK if the target interpreter of the alias is a slave of the + * invoking interpreter, TCL_ERROR else. + * + * Side effects: + * Sets the result of the invoking interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +GetTarget(askingInterp, path, aliasName) + Tcl_Interp *askingInterp; /* Interpreter to start search from. */ + char *path; /* The path of the interp to find. */ + char *aliasName; /* The target of this allias. */ +{ + Tcl_Interp *slaveInterp; /* Interim storage for slave. */ + Slave *slaveSlavePtr; /* Its Slave record. */ + Master *masterPtr; /* Interim storage for Master record. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Alias *aliasPtr; /* Data describing the alias. */ + + Tcl_ResetResult(askingInterp); + masterPtr = (Master *) Tcl_GetAssocData(askingInterp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("GetTarget: could not find master record"); + } + slaveInterp = GetInterp(askingInterp, masterPtr, path, NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp), + "could not find interpreter \"", path, "\"", (char *) NULL); + return TCL_ERROR; + } + slaveSlavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slaveSlavePtr == (Slave *) NULL) { + panic("GetTarget: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp), + "alias \"", aliasName, "\" in path \"", path, "\" not found", + (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (aliasPtr == (Alias *) NULL) { + panic("GetTarget: could not find alias record"); + } + + if (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) { + Tcl_ResetResult(askingInterp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp), + "target interpreter for alias \"", + aliasName, "\" in path \"", path, "\" is not my descendant", + (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InterpCmd -- + * + * This procedure is invoked to process the "interp" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +Tcl_InterpObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Unused. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Master *masterPtr; /* Master record for current interp. */ + int result; /* Local result variable. */ + + /* + * These are all the different subcommands for this command: + */ + + static char *subCmds[] = { + "alias", "aliases", "create", "delete", "eval", "exists", + "expose", "hide", "hidden", "issafe", "invokehidden", + "marktrusted", "slaves", "share", "target", "transfer", + (char *) NULL}; + enum ISubCmdIdx { + IAliasIdx, IAliasesIdx, ICreateIdx, IDeleteIdx, IEvalIdx, + IExistsIdx, IExposeIdx, IHideIdx, IHiddenIdx, IIsSafeIdx, + IInvokeHiddenIdx, IMarkTrustedIdx, ISlavesIdx, IShareIdx, + ITargetIdx, ITransferIdx + } index; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); + return TCL_ERROR; + } + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_InterpCmd: could not find master record"); + } + + result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", + 0, (int *) &index); + if (result != TCL_OK) { + return result; + } + + switch (index) { + case IAliasIdx: + return InterpAliasHelper(interp, masterPtr, objc, objv); + case IAliasesIdx: + return InterpAliasesHelper(interp, masterPtr, objc, objv); + case ICreateIdx: + return CreateInterpObject(interp, masterPtr, objc, objv); + case IDeleteIdx: + return DeleteInterpObject(interp, masterPtr, objc, objv); + case IEvalIdx: + return InterpEvalHelper(interp, masterPtr, objc, objv); + case IExistsIdx: + return InterpExistsHelper(interp, masterPtr, objc, objv); + case IExposeIdx: + return InterpExposeHelper(interp, masterPtr, objc, objv); + case IHideIdx: + return InterpHideHelper(interp, masterPtr, objc, objv); + case IHiddenIdx: + return InterpHiddenHelper(interp, masterPtr, objc, objv); + case IIsSafeIdx: + return InterpIsSafeHelper(interp, masterPtr, objc, objv); + case IInvokeHiddenIdx: + return InterpInvokeHiddenHelper(interp, masterPtr, objc, objv); + case IMarkTrustedIdx: + return InterpMarkTrustedHelper(interp, masterPtr, objc, objv); + case ISlavesIdx: + return InterpSlavesHelper(interp, masterPtr, objc, objv); + case IShareIdx: + return InterpShareHelper(interp, masterPtr, objc, objv); + case ITargetIdx: + return InterpTargetHelper(interp, masterPtr, objc, objv); + case ITransferIdx: + return InterpTransferHelper(interp, masterPtr, objc, objv); + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveAliasHelper -- + * + * Helper function to construct or query an alias for a slave + * interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Potentially creates a new alias. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Slave *slavePtr; /* Its slave record. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +{ + Master *masterPtr; + int len; + + switch (objc-2) { + case 0: + Tcl_WrongNumArgs(interp, 2, objv, + "aliasName ?targetName? ?args..?"); + return TCL_ERROR; + + case 1: + + /* + * Return the name of the command in the current + * interpreter for which the argument is an alias in the + * slave interpreter, and the list of saved arguments + */ + + return DescribeAlias(interp, slaveInterp, + Tcl_GetStringFromObj(objv[2], &len)); + + default: + masterPtr = (Master *) Tcl_GetAssocData(interp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveObjectCmd: could not find master record"); + } + return AliasCreationHelper(interp, slaveInterp, interp, + masterPtr, + Tcl_GetStringFromObj(objv[2], &len), + Tcl_GetStringFromObj(objv[3], &len), + objc-4, objv+4); + } +} + +/* + *---------------------------------------------------------------------- + * + * SlaveAliasesHelper -- + * + * Computes a list of aliases defined in a slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveAliasesHelper(interp, slaveInterp, slavePtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Slave *slavePtr; /* Its slave record. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +{ + Tcl_HashEntry *hPtr; /* For local searches. */ + Tcl_HashSearch hSearch; /* For local searches. */ + Tcl_Obj *listObjPtr; /* Local object pointer. */ + Alias *aliasPtr; /* Alias information. */ + + /* + * Return the names of all the aliases created in the + * slave interpreter. + */ + + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), + &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(aliasPtr->aliasName, -1)); + } + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveEvalHelper -- + * + * Helper function to evaluate a command in a slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Whatever the command does. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Slave *slavePtr; /* Its slave record. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +{ + Interp *iPtr; /* Internal data type for slave. */ + Tcl_Obj *objPtr; /* Local object pointer. */ + Tcl_Obj *namePtr; /* Local object pointer. */ + int len; + char *string; + int result; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); + return TCL_ERROR; + } + + objPtr = Tcl_ConcatObj(objc-2, objv+2); + Tcl_IncrRefCount(objPtr); + + Tcl_Preserve((ClientData) slaveInterp); + result = Tcl_EvalObj(slaveInterp, objPtr); + + Tcl_DecrRefCount(objPtr); + + /* + * Make the result and any error information accessible. We have + * to be careful because the slave interpreter and the current + * interpreter can be the same - do not destroy the result.. This + * can happen if an interpreter contains an alias which is directed + * at a target command in the same interpreter. + */ + + if (interp != slaveInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. + */ + + iPtr = (Interp *) slaveInterp; + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_AddErrorInfo(slaveInterp, ""); + } + iPtr->flags &= (~(ERR_ALREADY_LOGGED)); + + Tcl_ResetResult(interp); + namePtr = Tcl_NewStringObj("errorInfo", -1); + objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, + (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); + string = Tcl_GetStringFromObj(objPtr, &len); + Tcl_AddObjErrorInfo(interp, string, len); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) + NULL, TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(namePtr); + } + + /* + * Move the result object from one interpreter to the + * other. + */ + + Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); + Tcl_ResetResult(slaveInterp); + } + Tcl_Release((ClientData) slaveInterp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveExposeHelper -- + * + * Helper function to expose a command in a slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * After this call scripts in the slave will be able to invoke + * the newly exposed command. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Slave *slavePtr; /* Its slave record. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +{ + int len; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "permission denied: safe interpreter cannot expose commands", + (char *) NULL); + return TCL_ERROR; + } + if (Tcl_ExposeCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len), + (objc == 4 ? + Tcl_GetStringFromObj(objv[3], &len) : + Tcl_GetStringFromObj(objv[2], &len))) + == TCL_ERROR) { + Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); + Tcl_ResetResult(slaveInterp); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveHideHelper -- + * + * Helper function to hide a command in a slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * After this call scripts in the slave will no longer be able + * to invoke the named command. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Slave *slavePtr; /* Its slave record. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +{ + int len; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "permission denied: safe interpreter cannot hide commands", + (char *) NULL); + return TCL_ERROR; + } + if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len), + (objc == 4 ? + Tcl_GetStringFromObj(objv[3], &len) : + Tcl_GetStringFromObj(objv[2], &len))) + == TCL_ERROR) { + Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); + Tcl_ResetResult(slaveInterp); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveHiddenHelper -- + * + * Helper function to compute list of hidden commands in a slave + * interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Slave *slavePtr; /* Its slave record. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +{ + Tcl_Obj *listObjPtr; /* Local object pointer. */ + Tcl_HashTable *hTblPtr; /* For local searches. */ + Tcl_HashEntry *hPtr; /* For local searches. */ + Tcl_HashSearch hSearch; /* For local searches. */ + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp, + "tclHiddenCmds", NULL); + if (hTblPtr != (Tcl_HashTable *) NULL) { + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); + } + } + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveIsSafeHelper -- + * + * Helper function to compute whether a slave interpreter is safe. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Slave *slavePtr; /* Its slave record. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +{ + Tcl_Obj *resultPtr; /* Local object pointer. */ + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + resultPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp)); + + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveInvokeHiddenHelper -- + * + * Helper function to invoke a hidden command in a slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Whatever the hidden command does. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Slave *slavePtr; /* Its slave record. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +{ + Interp *iPtr; + Master *masterPtr; + int doGlobal = 0; + int result; + int len; + char *string; + Tcl_Obj *namePtr, *objPtr; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-global? cmd ?arg ..?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "not allowed to invoke hidden commands from safe interpreter", + (char *) NULL); + return TCL_ERROR; + } + if (strcmp(Tcl_GetStringFromObj(objv[2], &len), "-global") == 0) { + doGlobal = 1; + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "path ?-global? cmd ?arg ..?"); + return TCL_ERROR; + } + } + masterPtr = (Master *) Tcl_GetAssocData(slaveInterp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveObjectCmd: could not find master record"); + } + Tcl_Preserve((ClientData) slaveInterp); + if (doGlobal) { + result = TclObjInvokeGlobal(slaveInterp, objc-3, objv+3, + TCL_INVOKE_HIDDEN); + } else { + result = TclObjInvoke(slaveInterp, objc-2, objv+2, + TCL_INVOKE_HIDDEN); + } + + /* + * Now make the result and any error information accessible. We + * have to be careful because the slave interpreter and the current + * interpreter can be the same - do not destroy the result.. This + * can happen if an interpreter contains an alias which is directed + * at a target command in the same interpreter. + */ + + if (interp != slaveInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from + * the target interpreter back to our interpreter. + */ + + iPtr = (Interp *) slaveInterp; + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_AddErrorInfo(slaveInterp, ""); + } + iPtr->flags &= (~(ERR_ALREADY_LOGGED)); + + Tcl_ResetResult(interp); + namePtr = Tcl_NewStringObj("errorInfo", -1); + objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, + (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); + string = Tcl_GetStringFromObj(objPtr, &len); + Tcl_AddObjErrorInfo(interp, string, len); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) + NULL, TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(namePtr); + } + + /* + * Move the result object from the slave to the master. + */ + + Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); + Tcl_ResetResult(slaveInterp); + } + Tcl_Release((ClientData) slaveInterp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveMarkTrustedHelper -- + * + * Helper function to mark a slave interpreter as trusted (unsafe). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * After this call the hard-wired security checks in the core no + * longer prevent the slave from performing certain operations. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Slave *slavePtr; /* Its slave record. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +{ + int len; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", Tcl_GetStringFromObj(objv[0], &len), " marktrusted\"", + " can only be invoked from a trusted interpreter", + (char *) NULL); + return TCL_ERROR; + } + return MarkTrusted(slaveInterp); +} + +/* + *---------------------------------------------------------------------- + * + * SlaveObjectCmd -- + * + * Command to manipulate an interpreter, e.g. to send commands to it + * to be evaluated. One such command exists for each slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveObjectCmd(clientData, interp, objc, objv) + ClientData clientData; /* Slave interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument vector. */ +{ + Slave *slavePtr; /* Slave record. */ + Tcl_Interp *slaveInterp; /* Slave interpreter. */ + int result; /* Loop counter, status return. */ + int len; /* Length of command name. */ + + /* + * These are all the different subcommands for this command: + */ + + static char *subCmds[] = { + "alias", "aliases", + "eval", "expose", + "hide", "hidden", + "issafe", "invokehidden", + "marktrusted", + (char *) NULL}; + enum ISubCmdIdx { + IAliasIdx, IAliasesIdx, + IEvalIdx, IExposeIdx, + IHideIdx, IHiddenIdx, + IIsSafeIdx, IInvokeHiddenIdx, + IMarkTrustedIdx + } index; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); + return TCL_ERROR; + } + + slaveInterp = (Tcl_Interp *) clientData; + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter ", Tcl_GetStringFromObj(objv[0], &len), + " has been deleted", (char *) NULL); + return TCL_ERROR; + } + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, + "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + panic("SlaveObjectCmd: could not find slave record"); + } + + result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", + 0, (int *) &index); + if (result != TCL_OK) { + return result; + } + + switch (index) { + case IAliasIdx: + return SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv); + case IAliasesIdx: + return SlaveAliasesHelper(interp, slaveInterp, slavePtr, + objc, objv); + case IEvalIdx: + return SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv); + case IExposeIdx: + return SlaveExposeHelper(interp, slaveInterp, slavePtr, + objc, objv); + case IHideIdx: + return SlaveHideHelper(interp, slaveInterp, slavePtr, + objc, objv); + case IHiddenIdx: + return SlaveHiddenHelper(interp, slaveInterp, slavePtr, + objc, objv); + case IIsSafeIdx: + return SlaveIsSafeHelper(interp, slaveInterp, slavePtr, + objc, objv); + case IInvokeHiddenIdx: + return SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, + objc, objv); + case IMarkTrustedIdx: + return SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, + objc, objv); + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveObjectDeleteProc -- + * + * Invoked when an object command for a slave interpreter is deleted; + * cleans up all state associated with the slave interpreter and destroys + * the slave interpreter. + * + * Results: + * None. + * + * Side effects: + * Cleans up all state associated with the slave interpreter and + * destroys the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +SlaveObjectDeleteProc(clientData) + ClientData clientData; /* The SlaveRecord for the command. */ +{ + Slave *slavePtr; /* Interim storage for Slave record. */ + Tcl_Interp *slaveInterp; /* And for a slave interp. */ + + slaveInterp = (Tcl_Interp *) clientData; + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",NULL); + if (slavePtr == (Slave *) NULL) { + panic("SlaveObjectDeleteProc: could not find slave record"); + } + + /* + * Delete the entry in the slave table in the master interpreter now. + * This is to avoid an infinite loop in the Master hash table cleanup in + * the master interpreter. This can happen if this slave is being deleted + * because the master is being deleted and the slave deletion is deferred + * because it is still active. + */ + + Tcl_DeleteHashEntry(slavePtr->slaveEntry); + + /* + * Set to NULL so that when the slave record is cleaned up in the slave + * it does not try to delete the command causing all sorts of grief. + * See SlaveRecordDeleteProc(). + */ + + slavePtr->interpCmd = NULL; + + /* + * Destroy the interpreter - this will cause all the deleteProcs for + * all commands (including aliases) to run. + * + * NOTE: WE ASSUME THAT THE INTERPRETER HAS NOT BEEN DELETED YET!! + */ + + Tcl_DeleteInterp(slavePtr->slaveInterp); +} + +/* + *---------------------------------------------------------------------- + * + * AliasCmd -- + * + * This is the procedure that services invocations of aliases in a + * slave interpreter. One such command exists for each alias. When + * invoked, this procedure redirects the invocation to the target + * command in the master interpreter as designated by the Alias + * record associated with this command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Causes forwarding of the invocation; all possible side effects + * may occur as a result of invoking the command to which the + * invocation is forwarded. + * + *---------------------------------------------------------------------- + */ + +static int +AliasCmd(clientData, interp, objc, objv) + ClientData clientData; /* Alias record. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument vector. */ +{ + Tcl_Interp *targetInterp; /* Target for alias exec. */ + Interp *iPtr; /* Internal type of target. */ + Alias *aliasPtr; /* Describes the alias. */ + Tcl_Command cmd; /* The target command. */ + Command *cmdPtr; /* Points to target command. */ + Tcl_Namespace *targetNsPtr; /* Target command's namespace. */ + int result; /* Result of execution. */ + int i, j, addObjc; /* Loop counters. */ + int localObjc; /* Local argument count. */ + Tcl_Obj **localObjv; /* Local argument vector. */ + Tcl_Obj *namePtr, *objPtr; /* Local object pointers. */ + char *string; /* Local object string rep. */ + int len; /* Dummy length arg. */ + + aliasPtr = (Alias *) clientData; + targetInterp = aliasPtr->targetInterp; + + /* + * Look for the target command in the global namespace of the target + * interpreter. + */ + + cmdPtr = NULL; + targetNsPtr = Tcl_GetGlobalNamespace(aliasPtr->targetInterp); + cmd = Tcl_FindCommand(targetInterp, aliasPtr->targetName, + targetNsPtr, /*flags*/ 0); + if (cmd != (Tcl_Command) NULL) { + cmdPtr = (Command *) cmd; + } + + iPtr = (Interp *) targetInterp; + + /* + * If the command does not exist, invoke "unknown" in the master. + */ + + if (cmdPtr == NULL) { + addObjc = aliasPtr->objc; + localObjc = addObjc + objc + 1; + localObjv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) + * localObjc); + + localObjv[0] = Tcl_NewStringObj("unknown", -1); + localObjv[1] = Tcl_NewStringObj(aliasPtr->targetName, -1); + Tcl_IncrRefCount(localObjv[0]); + Tcl_IncrRefCount(localObjv[1]); + + for (i = 0, j = 2; i < addObjc; i++, j++) { + localObjv[j] = aliasPtr->objv[i]; + } + for (i = 1; i < objc; i++, j++) { + localObjv[j] = objv[i]; + } + Tcl_Preserve((ClientData) targetInterp); + result = TclObjInvoke(targetInterp, localObjc, localObjv, 0); + + Tcl_DecrRefCount(localObjv[0]); + Tcl_DecrRefCount(localObjv[1]); + + ckfree((char *) localObjv); + + if (targetInterp != interp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from + * the target interpreter back to our interpreter. + */ + + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_AddErrorInfo((Tcl_Interp *) iPtr, ""); + } + iPtr->flags &= (~(ERR_ALREADY_LOGGED)); + + Tcl_ResetResult(interp); + namePtr = Tcl_NewStringObj("errorInfo", -1); + objPtr = Tcl_ObjGetVar2(targetInterp, namePtr, + (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); + string = Tcl_GetStringFromObj(objPtr, &len); + Tcl_AddObjErrorInfo(interp, string, len); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(targetInterp, "errorCode", (char *) + NULL, TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(namePtr); + } + + /* + * Transfer the result from the target interpreter to the + * calling interpreter. + */ + + Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp)); + Tcl_ResetResult(targetInterp); + } + + Tcl_Release((ClientData) targetInterp); + return result; + } + + /* + * Otherwise invoke the regular target command. + */ + + if (aliasPtr->objc <= 0) { + localObjv = (Tcl_Obj **) objv; + localObjc = objc; + } else { + addObjc = aliasPtr->objc; + localObjc = objc + addObjc; + localObjv = + (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * localObjc); + localObjv[0] = objv[0]; + for (i = 0, j = 1; i < addObjc; i++, j++) { + localObjv[j] = aliasPtr->objv[i]; + } + for (i = 1; i < objc; i++, j++) { + localObjv[j] = objv[i]; + } + } + + iPtr->numLevels++; + Tcl_Preserve((ClientData) targetInterp); + + /* + * Reset the interpreter to its clean state; we do not know what state + * it is in now.. + */ + + Tcl_ResetResult(targetInterp); + result = (cmdPtr->objProc)(cmdPtr->objClientData, targetInterp, + localObjc, localObjv); + + iPtr->numLevels--; + + /* + * Check if we are at the bottom of the stack for the target interpreter. + * If so, check for special return codes. + */ + + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_ResetResult(targetInterp); + if (result == TCL_BREAK) { + Tcl_SetObjResult(targetInterp, + Tcl_NewStringObj("invoked \"break\" outside of a loop", + -1)); + } else if (result == TCL_CONTINUE) { + Tcl_SetObjResult(targetInterp, + Tcl_NewStringObj( + "invoked \"continue\" outside of a loop", + -1)); + } else { + char buf[128]; + + sprintf(buf, "command returned bad code: %d", result); + Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1)); + } + result = TCL_ERROR; + } + } + + /* + * Clean up any locally allocated argument vector structure. + */ + + if (localObjv != objv) { + ckfree((char *) localObjv); + } + + /* + * Move the result from the target interpreter to the invoking + * interpreter if they are different. + * + * Note: We cannot use aliasPtr any more because the alias may have + * been deleted. + */ + + if (interp != targetInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer the error information from + * the target interpreter back to our interpreter. + */ + + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_AddErrorInfo(targetInterp, ""); + } + iPtr->flags &= (~(ERR_ALREADY_LOGGED)); + + Tcl_ResetResult(interp); + namePtr = Tcl_NewStringObj("errorInfo", -1); + objPtr = Tcl_ObjGetVar2(targetInterp, namePtr, (Tcl_Obj *) NULL, + TCL_GLOBAL_ONLY); + string = Tcl_GetStringFromObj(objPtr, &len); + Tcl_AddObjErrorInfo(interp, string, len); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(targetInterp, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(namePtr); + } + + /* + * Move the result object from one interpreter to the + * other. + */ + + Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp)); + Tcl_ResetResult(targetInterp); + } + Tcl_Release((ClientData) targetInterp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * AliasCmdDeleteProc -- + * + * Is invoked when an alias command is deleted in a slave. Cleans up + * all storage associated with this alias. + * + * Results: + * None. + * + * Side effects: + * Deletes the alias record and its entry in the alias table for + * the interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +AliasCmdDeleteProc(clientData) + ClientData clientData; /* The alias record for this alias. */ +{ + Alias *aliasPtr; /* Alias record for alias to delete. */ + Target *targetPtr; /* Record for target of this alias. */ + int i; /* Loop counter. */ + + aliasPtr = (Alias *) clientData; + + targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntry); + ckfree((char *) targetPtr); + Tcl_DeleteHashEntry(aliasPtr->targetEntry); + + ckfree((char *) aliasPtr->targetName); + ckfree((char *) aliasPtr->aliasName); + for (i = 0; i < aliasPtr->objc; i++) { + Tcl_DecrRefCount(aliasPtr->objv[i]); + } + if (aliasPtr->objv != (Tcl_Obj **) NULL) { + ckfree((char *) aliasPtr->objv); + } + + Tcl_DeleteHashEntry(aliasPtr->aliasEntry); + + ckfree((char *) aliasPtr); +} + +/* + *---------------------------------------------------------------------- + * + * MasterRecordDeleteProc - + * + * Is invoked when an interpreter (which is using the "interp" facility) + * is deleted, and it cleans up the storage associated with the + * "tclMasterRecord" assoc-data entry. + * + * Results: + * None. + * + * Side effects: + * Cleans up storage. + * + *---------------------------------------------------------------------- + */ + +static void +MasterRecordDeleteProc(clientData, interp) + ClientData clientData; /* Master record for deleted interp. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + Target *targetPtr; /* Loop variable. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Tcl_HashSearch hSearch; /* Search record (internal). */ + Slave *slavePtr; /* Loop variable. */ + Master *masterPtr; /* Interim storage. */ + + masterPtr = (Master *) clientData; + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + (void) Tcl_DeleteCommandFromToken(interp, slavePtr->interpCmd); + } + Tcl_DeleteHashTable(&(masterPtr->slaveTable)); + + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) { + targetPtr = (Target *) Tcl_GetHashValue(hPtr); + (void) Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, + targetPtr->slaveCmd); + } + Tcl_DeleteHashTable(&(masterPtr->targetTable)); + + ckfree((char *) masterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SlaveRecordDeleteProc -- + * + * Is invoked when an interpreter (which is using the interp facility) + * is deleted, and it cleans up the storage associated with the + * tclSlaveRecord assoc-data entry. + * + * Results: + * None + * + * Side effects: + * Cleans up storage. + * + *---------------------------------------------------------------------- + */ + +static void +SlaveRecordDeleteProc(clientData, interp) + ClientData clientData; /* Slave record for deleted interp. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + Slave *slavePtr; /* Interim storage. */ + Alias *aliasPtr; + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + slavePtr = (Slave *) clientData; + + /* + * In every case that we call SetAssocData on "tclSlaveRecord", + * slavePtr is not NULL. Otherwise we panic. + */ + + if (slavePtr == NULL) { + panic("SlaveRecordDeleteProc: NULL slavePtr"); + } + + if (slavePtr->interpCmd != (Tcl_Command) NULL) { + Command *cmdPtr = (Command *) slavePtr->interpCmd; + + /* + * The interpCmd has not been deleted in the master yet, since + * it's callback sets interpCmd to NULL. + * + * Probably Tcl_DeleteInterp() was called on this interpreter directly, + * rather than via "interp delete", or equivalent (deletion of the + * command in the master). + * + * Perform the cleanup done by SlaveObjectDeleteProc() directly, + * and turn off the callback now (since we are about to free slavePtr + * and this interpreter is going away, while the deletion of commands + * in the master may be deferred). + */ + + Tcl_DeleteHashEntry(slavePtr->slaveEntry); + cmdPtr->clientData = NULL; + cmdPtr->deleteProc = NULL; + cmdPtr->deleteData = NULL; + + Tcl_DeleteCommandFromToken(slavePtr->masterInterp, + slavePtr->interpCmd); + } + + /* + * If there are any aliases, delete those now. This removes any + * dependency on the order of deletion between commands and the + * slave record. + */ + + hTblPtr = (Tcl_HashTable *) &(slavePtr->aliasTable); + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + + /* + * The call to Tcl_DeleteCommand will release the storage + * occupied by the hash entry and the alias record. + */ + + Tcl_DeleteCommandFromToken(interp, aliasPtr->slaveCmd); + } + + /* + * Finally dispose of the hash table and the slave record. + */ + + Tcl_DeleteHashTable(hTblPtr); + ckfree((char *) slavePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclInterpInit -- + * + * Initializes the invoking interpreter for using the "interp" + * facility. This is called from inside Tcl_Init. + * + * Results: + * None. + * + * Side effects: + * Adds the "interp" command to an interpreter and initializes several + * records in the associated data of the invoking interpreter. + * + *---------------------------------------------------------------------- + */ + +int +TclInterpInit(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + Master *masterPtr; /* Its Master record. */ + Slave *slavePtr; /* And its slave record. */ + + masterPtr = (Master *) ckalloc((unsigned) sizeof(Master)); + + Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS); + Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS); + + (void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc, + (ClientData) masterPtr); + + slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + + slavePtr->masterInterp = (Tcl_Interp *) NULL; + slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; + slavePtr->slaveInterp = interp; + slavePtr->interpCmd = (Tcl_Command) NULL; + Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); + + (void) Tcl_SetAssocData(interp, "tclSlaveRecord", SlaveRecordDeleteProc, + (ClientData) slavePtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsSafe -- + * + * Determines whether an interpreter is safe + * + * Results: + * 1 if it is safe, 0 if it is not. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsSafe(interp) + Tcl_Interp *interp; /* Is this interpreter "safe" ? */ +{ + Interp *iPtr; + + if (interp == (Tcl_Interp *) NULL) { + return 0; + } + iPtr = (Interp *) interp; + + return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateSlave -- + * + * Creates a slave interpreter. The slavePath argument denotes the + * name of the new slave relative to the current interpreter; the + * slave is a direct descendant of the one-before-last component of + * the path, e.g. it is a descendant of the current interpreter if + * the slavePath argument contains only one component. Optionally makes + * the slave interpreter safe. + * + * Results: + * Returns the interpreter structure created, or NULL if an error + * occurred. + * + * Side effects: + * Creates a new interpreter and a new interpreter object command in + * the interpreter indicated by the slavePath argument. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_CreateSlave(interp, slavePath, isSafe) + Tcl_Interp *interp; /* Interpreter to start search at. */ + char *slavePath; /* Name of slave to create. */ + int isSafe; /* Should new slave be "safe" ? */ +{ + Master *masterPtr; /* Master record for same. */ + + if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { + return NULL; + } + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("CreatSlave: could not find master record"); + } + return CreateSlave(interp, masterPtr, slavePath, isSafe); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetSlave -- + * + * Finds a slave interpreter by its path name. + * + * Results: + * Returns a Tcl_Interp * for the named interpreter or NULL if not + * found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_GetSlave(interp, slavePath) + Tcl_Interp *interp; /* Interpreter to start search from. */ + char *slavePath; /* Path of slave to find. */ +{ + Master *masterPtr; /* Interim storage for Master record. */ + + if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { + return NULL; + } + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_GetSlave: could not find master record"); + } + return GetInterp(interp, masterPtr, slavePath, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetMaster -- + * + * Finds the master interpreter of a slave interpreter. + * + * Results: + * Returns a Tcl_Interp * for the master interpreter or NULL if none. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_GetMaster(interp) + Tcl_Interp *interp; /* Get the master of this interpreter. */ +{ + Slave *slavePtr; /* Slave record of this interpreter. */ + + if (interp == (Tcl_Interp *) NULL) { + return NULL; + } + slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + return NULL; + } + return slavePtr->masterInterp; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateAlias -- + * + * Creates an alias between two interpreters. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates a new alias, manipulates the result field of slaveInterp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) + Tcl_Interp *slaveInterp; /* Interpreter for source command. */ + char *slaveCmd; /* Command to install in slave. */ + Tcl_Interp *targetInterp; /* Interpreter for target command. */ + char *targetCmd; /* Name of target command. */ + int argc; /* How many additional arguments? */ + char **argv; /* These are the additional args. */ +{ + Master *masterPtr; /* Master record for target interp. */ + Tcl_Obj **objv; + int i; + int result; + + if ((slaveInterp == (Tcl_Interp *) NULL) || + (targetInterp == (Tcl_Interp *) NULL) || + (slaveCmd == (char *) NULL) || + (targetCmd == (char *) NULL)) { + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_CreateAlias: could not find master record"); + } + objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc); + for (i = 0; i < argc; i++) { + objv[i] = Tcl_NewStringObj(argv[i], -1); + Tcl_IncrRefCount(objv[i]); + } + + result = AliasCreationHelper(slaveInterp, slaveInterp, targetInterp, + masterPtr, slaveCmd, targetCmd, argc, objv); + + ckfree((char *) objv); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateAliasObj -- + * + * Object version: Creates an alias between two interpreters. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates a new alias. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv) + Tcl_Interp *slaveInterp; /* Interpreter for source command. */ + char *slaveCmd; /* Command to install in slave. */ + Tcl_Interp *targetInterp; /* Interpreter for target command. */ + char *targetCmd; /* Name of target command. */ + int objc; /* How many additional arguments? */ + Tcl_Obj *CONST objv[]; /* Argument vector. */ +{ + Master *masterPtr; /* Master record for target interp. */ + + if ((slaveInterp == (Tcl_Interp *) NULL) || + (targetInterp == (Tcl_Interp *) NULL) || + (slaveCmd == (char *) NULL) || + (targetCmd == (char *) NULL)) { + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_CreateAlias: could not find master record"); + } + return AliasCreationHelper(slaveInterp, slaveInterp, targetInterp, + masterPtr, slaveCmd, targetCmd, objc, objv); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetAlias -- + * + * Gets information about an alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, + argvPtr) + Tcl_Interp *interp; /* Interp to start search from. */ + char *aliasName; /* Name of alias to find. */ + Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ + char **targetNamePtr; /* (Return) name of target command. */ + int *argcPtr; /* (Return) count of addnl args. */ + char ***argvPtr; /* (Return) additional arguments. */ +{ + Slave *slavePtr; /* Slave record for slave interp. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Alias *aliasPtr; /* Storage for alias found. */ + int len; + int i; + + if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) { + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + panic("Tcl_GetAlias: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", + (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (targetInterpPtr != (Tcl_Interp **) NULL) { + *targetInterpPtr = aliasPtr->targetInterp; + } + if (targetNamePtr != (char **) NULL) { + *targetNamePtr = aliasPtr->targetName; + } + if (argcPtr != (int *) NULL) { + *argcPtr = aliasPtr->objc; + } + if (argvPtr != (char ***) NULL) { + *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) * + aliasPtr->objc); + for (i = 0; i < aliasPtr->objc; i++) { + *argvPtr[i] = Tcl_GetStringFromObj(aliasPtr->objv[i], &len); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ObjGetAlias -- + * + * Object version: Gets information about an alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, + objvPtr) + Tcl_Interp *interp; /* Interp to start search from. */ + char *aliasName; /* Name of alias to find. */ + Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ + char **targetNamePtr; /* (Return) name of target command. */ + int *objcPtr; /* (Return) count of addnl args. */ + Tcl_Obj ***objvPtr; /* (Return) additional args. */ +{ + Slave *slavePtr; /* Slave record for slave interp. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Alias *aliasPtr; /* Storage for alias found. */ + + if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) { + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + panic("Tcl_GetAlias: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "alias \"", aliasName, "\" not found", (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (targetInterpPtr != (Tcl_Interp **) NULL) { + *targetInterpPtr = aliasPtr->targetInterp; + } + if (targetNamePtr != (char **) NULL) { + *targetNamePtr = aliasPtr->targetName; + } + if (objcPtr != (int *) NULL) { + *objcPtr = aliasPtr->objc; + } + if (objvPtr != (Tcl_Obj ***) NULL) { + *objvPtr = aliasPtr->objv; + } + return TCL_OK; +} diff --git a/tcl/generic/tclLink.c b/tcl/generic/tclLink.c new file mode 100644 index 00000000000..7addcd2e305 --- /dev/null +++ b/tcl/generic/tclLink.c @@ -0,0 +1,423 @@ +/* + * tclLink.c -- + * + * This file implements linked variables (a C variable that is + * tied to a Tcl variable). The idea of linked variables was + * first suggested by Andreas Stolcke and this implementation is + * based heavily on a prototype implementation provided by + * him. + * + * Copyright (c) 1993 The Regents of the University of California. + * Copyright (c) 1994-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * For each linked variable there is a data structure of the following + * type, which describes the link and is the clientData for the trace + * set on the Tcl variable. + */ + +typedef struct Link { + Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ + char *varName; /* Name of variable (must be global). This + * is needed during trace callbacks, since + * the actual variable may be aliased at + * that time via upvar. */ + char *addr; /* Location of C variable. */ + int type; /* Type of link (TCL_LINK_INT, etc.). */ + union { + int i; + double d; + } lastValue; /* Last known value of C variable; used to + * avoid string conversions. */ + int flags; /* Miscellaneous one-bit values; see below + * for definitions. */ +} Link; + +/* + * Definitions for flag bits: + * LINK_READ_ONLY - 1 means errors should be generated if Tcl + * script attempts to write variable. + * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar + * is in progress for this variable, so + * trace callbacks on the variable should + * be ignored. + */ + +#define LINK_READ_ONLY 1 +#define LINK_BEING_UPDATED 2 + +/* + * Forward references to procedures defined later in this file: + */ + +static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static char * StringValue _ANSI_ARGS_((Link *linkPtr, + char *buffer)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinkVar -- + * + * Link a C variable to a Tcl variable so that changes to either + * one causes the other to change. + * + * Results: + * The return value is TCL_OK if everything went well or TCL_ERROR + * if an error occurred (interp->result is also set after errors). + * + * Side effects: + * The value at *addr is linked to the Tcl variable "varName", + * using "type" to convert between string values for Tcl and + * binary values for *addr. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LinkVar(interp, varName, addr, type) + Tcl_Interp *interp; /* Interpreter in which varName exists. */ + char *varName; /* Name of a global variable in interp. */ + char *addr; /* Address of a C variable to be linked + * to varName. */ + int type; /* Type of C variable: TCL_LINK_INT, etc. + * Also may have TCL_LINK_READ_ONLY + * OR'ed in. */ +{ + Link *linkPtr; + char buffer[TCL_DOUBLE_SPACE]; + int code; + + linkPtr = (Link *) ckalloc(sizeof(Link)); + linkPtr->interp = interp; + linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1)); + strcpy(linkPtr->varName, varName); + linkPtr->addr = addr; + linkPtr->type = type & ~TCL_LINK_READ_ONLY; + if (type & TCL_LINK_READ_ONLY) { + linkPtr->flags = LINK_READ_ONLY; + } else { + linkPtr->flags = 0; + } + if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); + return TCL_ERROR; + } + code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS + |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, + (ClientData) linkPtr); + if (code != TCL_OK) { + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnlinkVar -- + * + * Destroy the link between a Tcl variable and a C variable. + * + * Results: + * None. + * + * Side effects: + * If "varName" was previously linked to a C variable, the link + * is broken to make the variable independent. If there was no + * previous link for "varName" then nothing happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UnlinkVar(interp, varName) + Tcl_Interp *interp; /* Interpreter containing variable to unlink. */ + char *varName; /* Global variable in interp to unlink. */ +{ + Link *linkPtr; + + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); + if (linkPtr == NULL) { + return; + } + Tcl_UntraceVar(interp, varName, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, (ClientData) linkPtr); + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpdateLinkedVar -- + * + * This procedure is invoked after a linked variable has been + * changed by C code. It updates the Tcl variable so that + * traces on the variable will trigger. + * + * Results: + * None. + * + * Side effects: + * The Tcl variable "varName" is updated from its C value, + * causing traces on the variable to trigger. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UpdateLinkedVar(interp, varName) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *varName; /* Name of global variable that is linked. */ +{ + Link *linkPtr; + char buffer[TCL_DOUBLE_SPACE]; + int savedFlag; + + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); + if (linkPtr == NULL) { + return; + } + savedFlag = linkPtr->flags & LINK_BEING_UPDATED; + linkPtr->flags |= LINK_BEING_UPDATED; + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; +} + +/* + *---------------------------------------------------------------------- + * + * LinkTraceProc -- + * + * This procedure is invoked when a linked Tcl variable is read, + * written, or unset from Tcl. It's responsible for keeping the + * C variable in sync with the Tcl variable. + * + * Results: + * If all goes well, NULL is returned; otherwise an error message + * is returned. + * + * Side effects: + * The C variable may be updated to make it consistent with the + * Tcl variable, or the Tcl variable may be overwritten to reject + * a modification. + * + *---------------------------------------------------------------------- + */ + +static char * +LinkTraceProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Contains information about the link. */ + Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ + char *name1; /* First part of variable name. */ + char *name2; /* Second part of variable name. */ + int flags; /* Miscellaneous additional information. */ +{ + Link *linkPtr = (Link *) clientData; + int changed; + char buffer[TCL_DOUBLE_SPACE]; + char *value, **pp; + Tcl_DString savedResult; + + /* + * If the variable is being unset, then just re-create it (with a + * trace) unless the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + if (flags & TCL_INTERP_DESTROYED) { + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); + } else if (flags & TCL_TRACE_DESTROYED) { + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY + |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, (ClientData) linkPtr); + } + return NULL; + } + + /* + * If we were invoked because of a call to Tcl_UpdateLinkedVar, then + * don't do anything at all. In particular, we don't want to get + * upset that the variable is being modified, even if it is + * supposed to be read-only. + */ + + if (linkPtr->flags & LINK_BEING_UPDATED) { + return NULL; + } + + /* + * For read accesses, update the Tcl variable if the C variable + * has changed since the last time we updated the Tcl variable. + */ + + if (flags & TCL_TRACE_READS) { + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i; + break; + case TCL_LINK_DOUBLE: + changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; + break; + case TCL_LINK_STRING: + changed = 1; + break; + default: + return "internal error: bad linked variable type"; + } + if (changed) { + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + } + return NULL; + } + + /* + * For writes, first make sure that the variable is writable. Then + * convert the Tcl value to C if possible. If the variable isn't + * writable or can't be converted, then restore the varaible's old + * value and return an error. Another tricky thing: we have to save + * and restore the interpreter's result, since the variable access + * could occur when the result has been partially set. + */ + + if (linkPtr->flags & LINK_READ_ONLY) { + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + return "linked variable is read-only"; + } + value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY); + if (value == NULL) { + /* + * This shouldn't ever happen. + */ + return "internal error: linked variable couldn't be read"; + } + Tcl_DStringInit(&savedResult); + Tcl_DStringAppend(&savedResult, interp->result, -1); + Tcl_ResetResult(interp); + switch (linkPtr->type) { + case TCL_LINK_INT: + if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); + return "variable must have integer value"; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + case TCL_LINK_DOUBLE: + if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d) + != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); + return "variable must have real value"; + } + *(double *)(linkPtr->addr) = linkPtr->lastValue.d; + break; + case TCL_LINK_BOOLEAN: + if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); + return "variable must have boolean value"; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + case TCL_LINK_STRING: + pp = (char **)(linkPtr->addr); + if (*pp != NULL) { + ckfree(*pp); + } + *pp = (char *) ckalloc((unsigned) (strlen(value) + 1)); + strcpy(*pp, value); + break; + default: + return "internal error: bad linked variable type"; + } + Tcl_DStringResult(interp, &savedResult); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * StringValue -- + * + * Converts the value of a C variable to a string for use in a + * Tcl variable to which it is linked. + * + * Results: + * The return value is a pointer + to a string that represents + * the value of the C variable given by linkPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +StringValue(linkPtr, buffer) + Link *linkPtr; /* Structure describing linked variable. */ + char *buffer; /* Small buffer to use for converting + * values. Must have TCL_DOUBLE_SPACE + * bytes or more. */ +{ + char *p; + + switch (linkPtr->type) { + case TCL_LINK_INT: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + TclFormatInt(buffer, linkPtr->lastValue.i); + return buffer; + case TCL_LINK_DOUBLE: + linkPtr->lastValue.d = *(double *)(linkPtr->addr); + Tcl_PrintDouble((Tcl_Interp *) NULL, linkPtr->lastValue.d, buffer); + return buffer; + case TCL_LINK_BOOLEAN: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + if (linkPtr->lastValue.i != 0) { + return "1"; + } + return "0"; + case TCL_LINK_STRING: + p = *(char **)(linkPtr->addr); + if (p == NULL) { + return "NULL"; + } + return p; + } + + /* + * This code only gets executed if the link type is unknown + * (shouldn't ever happen). + */ + + return "??"; +} diff --git a/tcl/generic/tclListObj.c b/tcl/generic/tclListObj.c new file mode 100644 index 00000000000..c7d9bca44a4 --- /dev/null +++ b/tcl/generic/tclListObj.c @@ -0,0 +1,1056 @@ +/* + * tclListObj.c -- + * + * This file contains procedures that implement the Tcl list object + * type. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright (c) 1998 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static void DupListInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void FreeListInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr)); +static int SetListFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfList _ANSI_ARGS_((Tcl_Obj *listPtr)); + +/* + * The structure below defines the list Tcl object type by means of + * procedures that can be invoked by generic object code. + */ + +Tcl_ObjType tclListType = { + "list", /* name */ + FreeListInternalRep, /* freeIntRepProc */ + DupListInternalRep, /* dupIntRepProc */ + UpdateStringOfList, /* updateStringProc */ + SetListFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewListObj -- + * + * This procedure is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new list object from an + * (objc,objv) array: that is, each of the objc elements of the array + * referenced by objv is inserted as an element into a new Tcl object. + * + * When TCL_MEM_DEBUG is defined, this procedure just returns the + * result of calling the debugging version Tcl_DbNewListObj. + * + * Results: + * A new list object is returned that is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation + * is left NULL. The resulting new list object has ref count 0. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewListObj + +Tcl_Obj * +Tcl_NewListObj(objc, objv) + int objc; /* Count of objects referenced by objv. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ +{ + return Tcl_DbNewListObj(objc, objv, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewListObj(objc, objv) + int objc; /* Count of objects referenced by objv. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ +{ + register Tcl_Obj *listPtr; + register Tcl_Obj **elemPtrs; + register List *listRepPtr; + int i; + + TclNewObj(listPtr); + + if (objc > 0) { + Tcl_InvalidateStringRep(listPtr); + + elemPtrs = (Tcl_Obj **) + ckalloc((unsigned) (objc * sizeof(Tcl_Obj *))); + for (i = 0; i < objc; i++) { + elemPtrs[i] = objv[i]; + Tcl_IncrRefCount(elemPtrs[i]); + } + + listRepPtr = (List *) ckalloc(sizeof(List)); + listRepPtr->maxElemCount = objc; + listRepPtr->elemCount = objc; + listRepPtr->elements = elemPtrs; + + listPtr->internalRep.otherValuePtr = (VOID *) listRepPtr; + listPtr->typePtr = &tclListType; + } + return listPtr; +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewListObj -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new list objects. It is the + * same as the Tcl_NewListObj procedure above except that it calls + * Tcl_DbCkalloc directly with the file name and line number from its + * caller. This simplifies debugging since then the checkmem command + * will report the correct file name and line number when reporting + * objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * result of calling Tcl_NewListObj. + * + * Results: + * A new list object is returned that is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation + * is left NULL. The new list object has ref count 0. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewListObj(objc, objv, file, line) + int objc; /* Count of objects referenced by objv. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + register Tcl_Obj *listPtr; + register Tcl_Obj **elemPtrs; + register List *listRepPtr; + int i; + + TclDbNewObj(listPtr, file, line); + + if (objc > 0) { + Tcl_InvalidateStringRep(listPtr); + + elemPtrs = (Tcl_Obj **) + ckalloc((unsigned) (objc * sizeof(Tcl_Obj *))); + for (i = 0; i < objc; i++) { + elemPtrs[i] = objv[i]; + Tcl_IncrRefCount(elemPtrs[i]); + } + + listRepPtr = (List *) ckalloc(sizeof(List)); + listRepPtr->maxElemCount = objc; + listRepPtr->elemCount = objc; + listRepPtr->elements = elemPtrs; + + listPtr->internalRep.otherValuePtr = (VOID *) listRepPtr; + listPtr->typePtr = &tclListType; + } + return listPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewListObj(objc, objv, file, line) + int objc; /* Count of objects referenced by objv. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return Tcl_NewListObj(objc, objv); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetListObj -- + * + * Modify an object to be a list containing each of the objc elements + * of the object array referenced by objv. + * + * Results: + * None. + * + * Side effects: + * The object is made a list object and is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation + * is left NULL. The ref counts of the elements in objv are incremented + * since the list now refers to them. The object's old string and + * internal representations are freed and its type is set NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetListObj(objPtr, objc, objv) + Tcl_Obj *objPtr; /* Object whose internal rep to init. */ + int objc; /* Count of objects referenced by objv. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ +{ + register Tcl_Obj **elemPtrs; + register List *listRepPtr; + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + int i; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetListObj called with shared object"); + } + + /* + * Free any old string rep and any internal rep for the old type. + */ + + Tcl_InvalidateStringRep(objPtr); + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + objPtr->typePtr = NULL; + + /* + * Set the object's type to "list" and initialize the internal rep. + */ + + if (objc > 0) { + elemPtrs = (Tcl_Obj **) + ckalloc((unsigned) (objc * sizeof(Tcl_Obj *))); + for (i = 0; i < objc; i++) { + elemPtrs[i] = objv[i]; + Tcl_IncrRefCount(elemPtrs[i]); + } + + listRepPtr = (List *) ckalloc(sizeof(List)); + listRepPtr->maxElemCount = objc; + listRepPtr->elemCount = objc; + listRepPtr->elements = elemPtrs; + + objPtr->internalRep.otherValuePtr = (VOID *) listRepPtr; + objPtr->typePtr = &tclListType; + } else { + objPtr->bytes = tclEmptyStringRep; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListObjGetElements -- + * + * This procedure returns an (objc,objv) array of the elements in a + * list object. + * + * Results: + * The return value is normally TCL_OK; in this case *objcPtr is set to + * the count of list elements and *objvPtr is set to a pointer to an + * array of (*objcPtr) pointers to each list element. If listPtr does + * not refer to a list object and the object can not be converted to + * one, TCL_ERROR is returned and an error message will be left in + * the interpreter's result if interp is not NULL. + * + * The objects referenced by the returned array should be treated as + * readonly and their ref counts are _not_ incremented; the caller must + * do that if it holds on to a reference. Furthermore, the pointer + * and length returned by this procedure may change as soon as any + * procedure is called on the list object; be careful about retaining + * the pointer in a local data structure. + * + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) + Tcl_Interp *interp; /* Used to report errors if not NULL. */ + register Tcl_Obj *listPtr; /* List object for which an element array + * is to be returned. */ + int *objcPtr; /* Where to store the count of objects + * referenced by objv. */ + Tcl_Obj ***objvPtr; /* Where to store the pointer to an array + * of pointers to the list's objects. */ +{ + register List *listRepPtr; + + if (listPtr->typePtr != &tclListType) { + int result = SetListFromAny(interp, listPtr); + if (result != TCL_OK) { + return result; + } + } + listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + *objcPtr = listRepPtr->elemCount; + *objvPtr = listRepPtr->elements; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListObjAppendList -- + * + * This procedure appends the objects in the list referenced by + * elemListPtr to the list object referenced by listPtr. If listPtr is + * not already a list object, an attempt will be made to convert it to + * one. + * + * Results: + * The return value is normally TCL_OK. If listPtr or elemListPtr do + * not refer to list objects and they can not be converted to one, + * TCL_ERROR is returned and an error message is left in + * the interpreter's result if interp is not NULL. + * + * Side effects: + * The reference counts of the elements in elemListPtr are incremented + * since the list now refers to them. listPtr and elemListPtr are + * converted, if necessary, to list objects. Also, appending the + * new elements may cause listObj's array of element pointers to grow. + * listPtr's old string representation, if any, is invalidated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ListObjAppendList(interp, listPtr, elemListPtr) + Tcl_Interp *interp; /* Used to report errors if not NULL. */ + register Tcl_Obj *listPtr; /* List object to append elements to. */ + Tcl_Obj *elemListPtr; /* List obj with elements to append. */ +{ + register List *listRepPtr; + int listLen, objc, result; + Tcl_Obj **objv; + + if (Tcl_IsShared(listPtr)) { + panic("Tcl_ListObjAppendList called with shared object"); + } + if (listPtr->typePtr != &tclListType) { + result = SetListFromAny(interp, listPtr); + if (result != TCL_OK) { + return result; + } + } + listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + listLen = listRepPtr->elemCount; + + result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv); + if (result != TCL_OK) { + return result; + } + + /* + * Insert objc new elements starting after the lists's last element. + * Delete zero existing elements. + */ + + return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListObjAppendElement -- + * + * This procedure is a special purpose version of + * Tcl_ListObjAppendList: it appends a single object referenced by + * objPtr to the list object referenced by listPtr. If listPtr is not + * already a list object, an attempt will be made to convert it to one. + * + * Results: + * The return value is normally TCL_OK; in this case objPtr is added + * to the end of listPtr's list. If listPtr does not refer to a list + * object and the object can not be converted to one, TCL_ERROR is + * returned and an error message will be left in the interpreter's + * result if interp is not NULL. + * + * Side effects: + * The ref count of objPtr is incremented since the list now refers + * to it. listPtr will be converted, if necessary, to a list object. + * Also, appending the new element may cause listObj's array of element + * pointers to grow. listPtr's old string representation, if any, + * is invalidated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ListObjAppendElement(interp, listPtr, objPtr) + Tcl_Interp *interp; /* Used to report errors if not NULL. */ + Tcl_Obj *listPtr; /* List object to append objPtr to. */ + Tcl_Obj *objPtr; /* Object to append to listPtr's list. */ +{ + register List *listRepPtr; + register Tcl_Obj **elemPtrs; + int numElems, numRequired; + + if (Tcl_IsShared(listPtr)) { + panic("Tcl_ListObjAppendElement called with shared object"); + } + if (listPtr->typePtr != &tclListType) { + int result = SetListFromAny(interp, listPtr); + if (result != TCL_OK) { + return result; + } + } + + listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + elemPtrs = listRepPtr->elements; + numElems = listRepPtr->elemCount; + numRequired = numElems + 1 ; + + /* + * If there is no room in the current array of element pointers, + * allocate a new, larger array and copy the pointers to it. + */ + + if (numRequired > listRepPtr->maxElemCount) { + int newMax = (2 * numRequired); + Tcl_Obj **newElemPtrs = (Tcl_Obj **) + ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); + + memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs, + (size_t) (numElems * sizeof(Tcl_Obj *))); + + listRepPtr->maxElemCount = newMax; + listRepPtr->elements = newElemPtrs; + ckfree((char *) elemPtrs); + elemPtrs = newElemPtrs; + } + + /* + * Add objPtr to the end of listPtr's array of element + * pointers. Increment the ref count for the (now shared) objPtr. + */ + + elemPtrs[numElems] = objPtr; + Tcl_IncrRefCount(objPtr); + listRepPtr->elemCount++; + + /* + * Invalidate any old string representation since the list's internal + * representation has changed. + */ + + Tcl_InvalidateStringRep(listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListObjIndex -- + * + * This procedure returns a pointer to the index'th object from the + * list referenced by listPtr. The first element has index 0. If index + * is negative or greater than or equal to the number of elements in + * the list, a NULL is returned. If listPtr is not a list object, an + * attempt will be made to convert it to a list. + * + * Results: + * The return value is normally TCL_OK; in this case objPtrPtr is set + * to the Tcl_Obj pointer for the index'th list element or NULL if + * index is out of range. This object should be treated as readonly and + * its ref count is _not_ incremented; the caller must do that if it + * holds on to the reference. If listPtr does not refer to a list and + * can't be converted to one, TCL_ERROR is returned and an error + * message is left in the interpreter's result if interp is not NULL. + * + * Side effects: + * listPtr will be converted, if necessary, to a list object. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr) + Tcl_Interp *interp; /* Used to report errors if not NULL. */ + register Tcl_Obj *listPtr; /* List object to index into. */ + register int index; /* Index of element to return. */ + Tcl_Obj **objPtrPtr; /* The resulting Tcl_Obj* is stored here. */ +{ + register List *listRepPtr; + + if (listPtr->typePtr != &tclListType) { + int result = SetListFromAny(interp, listPtr); + if (result != TCL_OK) { + return result; + } + } + + listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + if ((index < 0) || (index >= listRepPtr->elemCount)) { + *objPtrPtr = NULL; + } else { + *objPtrPtr = listRepPtr->elements[index]; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListObjLength -- + * + * This procedure returns the number of elements in a list object. If + * the object is not already a list object, an attempt will be made to + * convert it to one. + * + * Results: + * The return value is normally TCL_OK; in this case *intPtr will be + * set to the integer count of list elements. If listPtr does not refer + * to a list object and the object can not be converted to one, + * TCL_ERROR is returned and an error message will be left in + * the interpreter's result if interp is not NULL. + * + * Side effects: + * The possible conversion of the argument object to a list object. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ListObjLength(interp, listPtr, intPtr) + Tcl_Interp *interp; /* Used to report errors if not NULL. */ + register Tcl_Obj *listPtr; /* List object whose #elements to return. */ + register int *intPtr; /* The resulting int is stored here. */ +{ + register List *listRepPtr; + + if (listPtr->typePtr != &tclListType) { + int result = SetListFromAny(interp, listPtr); + if (result != TCL_OK) { + return result; + } + } + + listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + *intPtr = listRepPtr->elemCount; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListObjReplace -- + * + * This procedure replaces zero or more elements of the list referenced + * by listPtr with the objects from an (objc,objv) array. + * The objc elements of the array referenced by objv replace the + * count elements in listPtr starting at first. + * + * If the argument first is zero or negative, it refers to the first + * element. If first is greater than or equal to the number of elements + * in the list, then no elements are deleted; the new elements are + * appended to the list. Count gives the number of elements to + * replace. If count is zero or negative then no elements are deleted; + * the new elements are simply inserted before first. + * + * The argument objv refers to an array of objc pointers to the new + * elements to be added to listPtr in place of those that were + * deleted. If objv is NULL, no new elements are added. If listPtr is + * not a list object, an attempt will be made to convert it to one. + * + * Results: + * The return value is normally TCL_OK. If listPtr does + * not refer to a list object and can not be converted to one, + * TCL_ERROR is returned and an error message will be left in + * the interpreter's result if interp is not NULL. + * + * Side effects: + * The ref counts of the objc elements in objv are incremented since + * the resulting list now refers to them. Similarly, the ref counts for + * replaced objects are decremented. listPtr is converted, if + * necessary, to a list object. listPtr's old string representation, if + * any, is freed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *listPtr; /* List object whose elements to replace. */ + int first; /* Index of first element to replace. */ + int count; /* Number of elements to replace. */ + int objc; /* Number of objects to insert. */ + Tcl_Obj *CONST objv[]; /* An array of objc pointers to Tcl objects + * to insert. */ +{ + List *listRepPtr; + register Tcl_Obj **elemPtrs, **newPtrs; + Tcl_Obj *victimPtr; + int numElems, numRequired, numAfterLast; + int start, shift, newMax, i, j, result; + + if (Tcl_IsShared(listPtr)) { + panic("Tcl_ListObjReplace called with shared object"); + } + if (listPtr->typePtr != &tclListType) { + result = SetListFromAny(interp, listPtr); + if (result != TCL_OK) { + return result; + } + } + listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + elemPtrs = listRepPtr->elements; + numElems = listRepPtr->elemCount; + + if (first < 0) { + first = 0; + } + if (first >= numElems) { + first = numElems; /* so we'll insert after last element */ + } + if (count < 0) { + count = 0; + } + + numRequired = (numElems - count + objc); + if (numRequired <= listRepPtr->maxElemCount) { + /* + * Enough room in the current array. First "delete" count + * elements starting at first. + */ + + for (i = 0, j = first; i < count; i++, j++) { + victimPtr = elemPtrs[j]; + TclDecrRefCount(victimPtr); + } + + /* + * Shift the elements after the last one removed to their + * new locations. + */ + + start = (first + count); + numAfterLast = (numElems - start); + shift = (objc - count); /* numNewElems - numDeleted */ + if ((numAfterLast > 0) && (shift != 0)) { + Tcl_Obj **src, **dst; + + if (shift < 0) { + for (src = elemPtrs + start, dst = src + shift; + numAfterLast > 0; numAfterLast--, src++, dst++) { + *dst = *src; + } + } else { + for (src = elemPtrs + numElems - 1, dst = src + shift; + numAfterLast > 0; numAfterLast--, src--, dst--) { + *dst = *src; + } + } + } + + /* + * Insert the new elements into elemPtrs before "first". + */ + + for (i = 0, j = first; i < objc; i++, j++) { + elemPtrs[j] = objv[i]; + Tcl_IncrRefCount(objv[i]); + } + + /* + * Update the count of elements. + */ + + listRepPtr->elemCount = numRequired; + } else { + /* + * Not enough room in the current array. Allocate a larger array and + * insert elements into it. + */ + + newMax = (2 * numRequired); + newPtrs = (Tcl_Obj **) + ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); + + /* + * Copy over the elements before "first". + */ + + if (first > 0) { + memcpy((VOID *) newPtrs, (VOID *) elemPtrs, + (size_t) (first * sizeof(Tcl_Obj *))); + } + + /* + * "Delete" count elements starting at first. + */ + + for (i = 0, j = first; i < count; i++, j++) { + victimPtr = elemPtrs[j]; + TclDecrRefCount(victimPtr); + } + + /* + * Copy the elements after the last one removed, shifted to + * their new locations. + */ + + start = (first + count); + numAfterLast = (numElems - start); + if (numAfterLast > 0) { + memcpy((VOID *) &(newPtrs[first + objc]), + (VOID *) &(elemPtrs[start]), + (size_t) (numAfterLast * sizeof(Tcl_Obj *))); + } + + /* + * Insert the new elements before "first" and update the + * count of elements. + */ + + for (i = 0, j = first; i < objc; i++, j++) { + newPtrs[j] = objv[i]; + Tcl_IncrRefCount(objv[i]); + } + + listRepPtr->elemCount = numRequired; + listRepPtr->maxElemCount = newMax; + listRepPtr->elements = newPtrs; + ckfree((char *) elemPtrs); + } + + /* + * Invalidate and free any old string representation since it no longer + * reflects the list's internal representation. + */ + + Tcl_InvalidateStringRep(listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FreeListInternalRep -- + * + * Deallocate the storage associated with a list object's internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Frees listPtr's List* internal representation and sets listPtr's + * internalRep.otherValuePtr to NULL. Decrements the ref counts + * of all element objects, which may free them. + * + *---------------------------------------------------------------------- + */ + +static void +FreeListInternalRep(listPtr) + Tcl_Obj *listPtr; /* List object with internal rep to free. */ +{ + register List *listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + register Tcl_Obj **elemPtrs = listRepPtr->elements; + register Tcl_Obj *objPtr; + int numElems = listRepPtr->elemCount; + int i; + + for (i = 0; i < numElems; i++) { + objPtr = elemPtrs[i]; + Tcl_DecrRefCount(objPtr); + } + ckfree((char *) elemPtrs); + ckfree((char *) listRepPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DupListInternalRep -- + * + * Initialize the internal representation of a list Tcl_Obj to a + * copy of the internal representation of an existing list object. + * + * Results: + * None. + * + * Side effects: + * "srcPtr"s list internal rep pointer should not be NULL and we assume + * it is not NULL. We set "copyPtr"s internal rep to a pointer to a + * newly allocated List structure that, in turn, points to "srcPtr"s + * element objects. Those element objects are not actually copied but + * are shared between "srcPtr" and "copyPtr". The ref count of each + * element object is incremented. + * + *---------------------------------------------------------------------- + */ + +static void +DupListInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + List *srcListRepPtr = (List *) srcPtr->internalRep.otherValuePtr; + int numElems = srcListRepPtr->elemCount; + int maxElems = srcListRepPtr->maxElemCount; + register Tcl_Obj **srcElemPtrs = srcListRepPtr->elements; + register Tcl_Obj **copyElemPtrs; + register List *copyListRepPtr; + int i; + + /* + * Allocate a new List structure that points to "srcPtr"s element + * objects. Increment the ref counts for those (now shared) element + * objects. + */ + + copyElemPtrs = (Tcl_Obj **) + ckalloc((unsigned) maxElems * sizeof(Tcl_Obj *)); + for (i = 0; i < numElems; i++) { + copyElemPtrs[i] = srcElemPtrs[i]; + Tcl_IncrRefCount(copyElemPtrs[i]); + } + + copyListRepPtr = (List *) ckalloc(sizeof(List)); + copyListRepPtr->maxElemCount = maxElems; + copyListRepPtr->elemCount = numElems; + copyListRepPtr->elements = copyElemPtrs; + + copyPtr->internalRep.otherValuePtr = (VOID *) copyListRepPtr; + copyPtr->typePtr = &tclListType; +} + +/* + *---------------------------------------------------------------------- + * + * SetListFromAny -- + * + * Attempt to generate a list internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is TCL_OK or TCL_ERROR. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * If no error occurs, a list is stored as "objPtr"s internal + * representation. + * + *---------------------------------------------------------------------- + */ + +static int +SetListFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *elemStart, *nextElem, *s; + int lenRemain, length, estCount, elemSize, hasBrace, i, j, result; + char *limit; /* Points just after string's last byte. */ + register char *p; + register Tcl_Obj **elemPtrs; + register Tcl_Obj *elemPtr; + List *listRepPtr; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + + /* + * Parse the string into separate string objects, and create a List + * structure that points to the element string objects. We use a + * modified version of Tcl_SplitList's implementation to avoid one + * malloc and a string copy for each list element. First, estimate the + * number of elements by counting the number of space characters in the + * list. + */ + + limit = (string + length); + estCount = 1; + for (p = string; p < limit; p++) { + if (isspace(UCHAR(*p))) { + estCount++; + } + } + + /* + * Allocate a new List structure with enough room for "estCount" + * elements. Each element is a pointer to a Tcl_Obj with the appropriate + * string rep. The initial "estCount" elements are set using the + * corresponding "argv" strings. + */ + + elemPtrs = (Tcl_Obj **) + ckalloc((unsigned) (estCount * sizeof(Tcl_Obj *))); + for (p = string, lenRemain = length, i = 0; + lenRemain > 0; + p = nextElem, lenRemain = (limit - nextElem), i++) { + result = TclFindElement(interp, p, lenRemain, &elemStart, &nextElem, + &elemSize, &hasBrace); + if (result != TCL_OK) { + for (j = 0; j < i; j++) { + elemPtr = elemPtrs[j]; + Tcl_DecrRefCount(elemPtr); + } + ckfree((char *) elemPtrs); + return result; + } + if (elemStart >= limit) { + break; + } + if (i > estCount) { + panic("SetListFromAny: bad size estimate for list"); + } + + /* + * Allocate a Tcl object for the element and initialize it from the + * "elemSize" bytes starting at "elemStart". + */ + + s = ckalloc((unsigned) elemSize + 1); + if (hasBrace) { + memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); + s[elemSize] = 0; + } else { + elemSize = TclCopyAndCollapse(elemSize, elemStart, s); + } + + TclNewObj(elemPtr); + elemPtr->bytes = s; + elemPtr->length = elemSize; + elemPtrs[i] = elemPtr; + Tcl_IncrRefCount(elemPtr); /* since list now holds ref to it */ + } + + listRepPtr = (List *) ckalloc(sizeof(List)); + listRepPtr->maxElemCount = estCount; + listRepPtr->elemCount = i; + listRepPtr->elements = elemPtrs; + + /* + * Free the old internalRep before setting the new one. We do this as + * late as possible to allow the conversion code, in particular + * Tcl_GetStringFromObj, to use that old internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.otherValuePtr = (VOID *) listRepPtr; + objPtr->typePtr = &tclListType; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfList -- + * + * Update the string representation for a list object. + * Note: This procedure does not invalidate an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the list-to-string conversion. This string will be empty if the + * list has no elements. The list internal representation + * should not be NULL and we assume it is not NULL. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfList(listPtr) + Tcl_Obj *listPtr; /* List object with string rep to update. */ +{ +# define LOCAL_SIZE 20 + int localFlags[LOCAL_SIZE], *flagPtr; + List *listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + int numElems = listRepPtr->elemCount; + register int i; + char *elem, *dst; + int length; + + /* + * Convert each element of the list to string form and then convert it + * to proper list element form, adding it to the result buffer. + */ + + /* + * Pass 1: estimate space, gather flags. + */ + + if (numElems <= LOCAL_SIZE) { + flagPtr = localFlags; + } else { + flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); + } + listPtr->length = 1; + for (i = 0; i < numElems; i++) { + elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length); + listPtr->length += Tcl_ScanCountedElement(elem, length, + &flagPtr[i]) + 1; + } + + /* + * Pass 2: copy into string rep buffer. + */ + + listPtr->bytes = ckalloc((unsigned) listPtr->length); + dst = listPtr->bytes; + for (i = 0; i < numElems; i++) { + elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length); + dst += Tcl_ConvertCountedElement(elem, length, dst, flagPtr[i]); + *dst = ' '; + dst++; + } + if (flagPtr != localFlags) { + ckfree((char *) flagPtr); + } + if (dst == listPtr->bytes) { + *dst = 0; + } else { + dst--; + *dst = 0; + } + listPtr->length = dst - listPtr->bytes; +} diff --git a/tcl/generic/tclLoad.c b/tcl/generic/tclLoad.c new file mode 100644 index 00000000000..3502889a5f7 --- /dev/null +++ b/tcl/generic/tclLoad.c @@ -0,0 +1,636 @@ +/* + * tclLoad.c -- + * + * This file provides the generic portion (those that are the same + * on all platforms) of Tcl's dynamic loading facilities. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * The following structure describes a package that has been loaded + * either dynamically (with the "load" command) or statically (as + * indicated by a call to Tcl_PackageLoaded). All such packages + * are linked together into a single list for the process. Packages + * are never unloaded, so these structures are never freed. + */ + +typedef struct LoadedPackage { + char *fileName; /* Name of the file from which the + * package was loaded. An empty string + * means the package is loaded statically. + * Malloc-ed. */ + char *packageName; /* Name of package prefix for the package, + * properly capitalized (first letter UC, + * others LC), no "_", as in "Net". + * Malloc-ed. */ + Tcl_PackageInitProc *initProc; + /* Initialization procedure to call to + * incorporate this package into a trusted + * interpreter. */ + Tcl_PackageInitProc *safeInitProc; + /* Initialization procedure to call to + * incorporate this package into a safe + * interpreter (one that will execute + * untrusted scripts). NULL means the + * package can't be used in unsafe + * interpreters. */ + struct LoadedPackage *nextPtr; + /* Next in list of all packages loaded into + * this application process. NULL means + * end of list. */ +} LoadedPackage; + +static LoadedPackage *firstPackagePtr = NULL; + /* First in list of all packages loaded into + * this process. */ + +/* + * The following structure represents a particular package that has + * been incorporated into a particular interpreter (by calling its + * initialization procedure). There is a list of these structures for + * each interpreter, with an AssocData value (key "load") for the + * interpreter that points to the first package (if any). + */ + +typedef struct InterpPackage { + LoadedPackage *pkgPtr; /* Points to detailed information about + * package. */ + struct InterpPackage *nextPtr; + /* Next package in this interpreter, or + * NULL for end of list. */ +} InterpPackage; + +/* + * Prototypes for procedures that are private to this file: + */ + +static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void LoadExitProc _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_LoadCmd -- + * + * This procedure is invoked to process the "load" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LoadCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *target; + LoadedPackage *pkgPtr, *defaultPtr; + Tcl_DString pkgName, initName, safeInitName, fileName; + Tcl_PackageInitProc *initProc, *safeInitProc; + InterpPackage *ipFirstPtr, *ipPtr; + int code, c, gotPkgName, namesMatch, filesMatch; + char *p, *fullFileName, *p1, *p2; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName ?packageName? ?interp?\"", (char *) NULL); + return TCL_ERROR; + } + fullFileName = Tcl_TranslateFileName(interp, argv[1], &fileName); + if (fullFileName == NULL) { + return TCL_ERROR; + } + Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&initName); + Tcl_DStringInit(&safeInitName); + if ((argc >= 3) && (argv[2][0] != 0)) { + gotPkgName = 1; + } else { + gotPkgName = 0; + } + if ((fullFileName[0] == 0) && !gotPkgName) { + Tcl_SetResult(interp, + "must specify either file name or package name", + TCL_STATIC); + code = TCL_ERROR; + goto done; + } + + /* + * Figure out which interpreter we're going to load the package into. + */ + + target = interp; + if (argc == 4) { + target = Tcl_GetSlave(interp, argv[3]); + if (target == NULL) { + Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * Scan through the packages that are currently loaded to see if the + * package we want is already loaded. We'll use a loaded package if + * it meets any of the following conditions: + * - Its name and file match the once we're looking for. + * - Its file matches, and we weren't given a name. + * - Its name matches, the file name was specified as empty, and there + * is only no statically loaded package with the same name. + */ + + defaultPtr = NULL; + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + if (!gotPkgName) { + namesMatch = 0; + } else { + namesMatch = 1; + for (p1 = argv[2], p2 = pkgPtr->packageName; ; p1++, p2++) { + if ((isupper(UCHAR(*p1)) ? tolower(UCHAR(*p1)) : *p1) + != (isupper(UCHAR(*p2)) ? tolower(UCHAR(*p2)) : *p2)) { + namesMatch = 0; + break; + } + if (*p1 == 0) { + break; + } + } + } + filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || !gotPkgName)) { + break; + } + if (namesMatch && (fullFileName[0] == 0)) { + defaultPtr = pkgPtr; + } + if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { + /* + * Can't have two different packages loaded from the same + * file. + */ + + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" is already loaded for package \"", + pkgPtr->packageName, "\"", (char *) NULL); + code = TCL_ERROR; + goto done; + } + } + if (pkgPtr == NULL) { + pkgPtr = defaultPtr; + } + + /* + * Scan through the list of packages already loaded in the target + * interpreter. If the package we want is already loaded there, + * then there's nothing for us to to. + */ + + if (pkgPtr != NULL) { + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->pkgPtr == pkgPtr) { + code = TCL_OK; + goto done; + } + } + } + + if (pkgPtr == NULL) { + /* + * The desired file isn't currently loaded, so load it. It's an + * error if the desired package is a static one. + */ + + if (fullFileName[0] == 0) { + Tcl_AppendResult(interp, "package \"", argv[2], + "\" isn't loaded statically", (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Figure out the module name if it wasn't provided explicitly. + */ + + if (gotPkgName) { + Tcl_DStringAppend(&pkgName, argv[2], -1); + } else { + if (!TclGuessPackageName(fullFileName, &pkgName)) { + int pargc; + char **pargv, *pkgGuess; + + /* + * The platform-specific code couldn't figure out the + * module name. Make a guess by taking the last element + * of the file name, stripping off any leading "lib", + * and then using all of the alphabetic and underline + * characters that follow that. + */ + + Tcl_SplitPath(fullFileName, &pargc, &pargv); + pkgGuess = pargv[pargc-1]; + if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') + && (pkgGuess[2] == 'b')) { + pkgGuess += 3; + } + for (p = pkgGuess; isalpha(UCHAR(*p)) || (*p == '_'); p++) { + /* Empty loop body. */ + } + if (p == pkgGuess) { + ckfree((char *)pargv); + Tcl_AppendResult(interp, + "couldn't figure out package name for ", + fullFileName, (char *) NULL); + code = TCL_ERROR; + goto done; + } + Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess)); + ckfree((char *)pargv); + } + } + + /* + * Fix the capitalization in the package name so that the first + * character is in caps but the others are all lower-case. + */ + + p = Tcl_DStringValue(&pkgName); + c = UCHAR(*p); + if (c != 0) { + if (islower(c)) { + *p = (char) toupper(c); + } + p++; + while (1) { + c = UCHAR(*p); + if (c == 0) { + break; + } + if (isupper(c)) { + *p = (char) tolower(c); + } + p++; + } + } + + /* + * Compute the names of the two initialization procedures, + * based on the package name. + */ + + Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&initName, "_Init", 5); + Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); + + /* + * Call platform-specific code to load the package and find the + * two initialization procedures. + */ + + code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), + Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc); + if (code != TCL_OK) { + goto done; + } + if (initProc == NULL) { + Tcl_AppendResult(interp, "couldn't find procedure ", + Tcl_DStringValue(&initName), (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Create a new record to describe this package. + */ + + if (firstPackagePtr == NULL) { + Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); + } + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) + (strlen(fullFileName) + 1)); + strcpy(pkgPtr->fileName, fullFileName); + pkgPtr->packageName = (char *) ckalloc((unsigned) + (Tcl_DStringLength(&pkgName) + 1)); + strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + } + + /* + * Invoke the package's initialization procedure (either the + * normal one or the safe one, depending on whether or not the + * interpreter is safe). + */ + + if (Tcl_IsSafe(target)) { + if (pkgPtr->safeInitProc != NULL) { + code = (*pkgPtr->safeInitProc)(target); + } else { + Tcl_AppendResult(interp, + "can't use package in a safe interpreter: ", + "no ", pkgPtr->packageName, "_SafeInit procedure", + (char *) NULL); + code = TCL_ERROR; + goto done; + } + } else { + code = (*pkgPtr->initProc)(target); + } + if ((code == TCL_ERROR) && (target != interp)) { + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Must clear + * interp's result before calling Tcl_AddErrorInfo, since + * Tcl_AddErrorInfo will store the interp's result in errorInfo + * before appending target's $errorInfo; we've already got + * everything we need in target's $errorInfo. + */ + + /* + * It is (abusively) assumed that errorInfo and errorCode vars exists. + * we changed SetVar2 to accept NULL values to avoid crashes. --dl + */ + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(target, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(target, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + Tcl_SetResult(interp, target->result, TCL_VOLATILE); + } + + /* + * Record the fact that the package has been loaded in the + * target interpreter. + */ + + if (code == TCL_OK) { + /* + * Refetch ipFirstPtr: loading the package may have introduced + * additional static packages at the head of the linked list! + */ + + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; + ipPtr->nextPtr = ipFirstPtr; + Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); + } + + done: + Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&initName); + Tcl_DStringFree(&safeInitName); + Tcl_DStringFree(&fileName); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StaticPackage -- + * + * This procedure is invoked to indicate that a particular + * package has been linked statically with an application. + * + * Results: + * None. + * + * Side effects: + * Once this procedure completes, the package becomes loadable + * via the "load" command with an empty file name. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) + Tcl_Interp *interp; /* If not NULL, it means that the + * package has already been loaded + * into the given interpreter by + * calling the appropriate init proc. */ + char *pkgName; /* Name of package (must be properly + * capitalized: first letter upper + * case, others lower case). */ + Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate + * this package into a trusted + * interpreter. */ + Tcl_PackageInitProc *safeInitProc; /* Procedure to call to incorporate + * this package into a safe interpreter + * (one that will execute untrusted + * scripts). NULL means the package + * can't be used in safe + * interpreters. */ +{ + LoadedPackage *pkgPtr; + InterpPackage *ipPtr, *ipFirstPtr; + + /* + * Check to see if someone else has already reported this package as + * statically loaded. If this call is redundant then just return. + */ + + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + if ((pkgPtr->initProc == initProc) + && (pkgPtr->safeInitProc == safeInitProc) + && (strcmp(pkgPtr->packageName, pkgName) == 0)) { + return; + } + } + + if (firstPackagePtr == NULL) { + Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); + } + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) 1); + pkgPtr->fileName[0] = 0; + pkgPtr->packageName = (char *) ckalloc((unsigned) + (strlen(pkgName) + 1)); + strcpy(pkgPtr->packageName, pkgName); + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + + if (interp != NULL) { + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; + ipPtr->nextPtr = ipFirstPtr; + Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetLoadedPackages -- + * + * This procedure returns information about all of the files + * that are loaded (either in a particular intepreter, or + * for all interpreters). + * + * Results: + * The return value is a standard Tcl completion code. If + * successful, a list of lists is placed in interp->result. + * Each sublist corresponds to one loaded file; its first + * element is the name of the file (or an empty string for + * something that's statically loaded) and the second element + * is the name of the package in that file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetLoadedPackages(interp, targetName) + Tcl_Interp *interp; /* Interpreter in which to return + * information or error message. */ + char *targetName; /* Name of target interpreter or NULL. + * If NULL, return info about all interps; + * otherwise, just return info about this + * interpreter. */ +{ + Tcl_Interp *target; + LoadedPackage *pkgPtr; + InterpPackage *ipPtr; + char *prefix; + + if (targetName == NULL) { + /* + * Return information about all of the available packages. + */ + + prefix = "{"; + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; + pkgPtr = pkgPtr->nextPtr) { + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; + } + return TCL_OK; + } + + /* + * Return information about only the packages that are loaded in + * a given interpreter. + */ + + target = Tcl_GetSlave(interp, targetName); + if (target == NULL) { + Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", + targetName, "\"", (char *) NULL); + return TCL_ERROR; + } + ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + prefix = "{"; + for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + pkgPtr = ipPtr->pkgPtr; + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * LoadCleanupProc -- + * + * This procedure is called to delete all of the InterpPackage + * structures for an interpreter when the interpreter is deleted. + * It gets invoked via the Tcl AssocData mechanism. + * + * Results: + * None. + * + * Side effects: + * Storage for all of the InterpPackage procedures for interp + * get deleted. + * + *---------------------------------------------------------------------- + */ + +static void +LoadCleanupProc(clientData, interp) + ClientData clientData; /* Pointer to first InterpPackage structure + * for interp. */ + Tcl_Interp *interp; /* Interpreter that is being deleted. */ +{ + InterpPackage *ipPtr, *nextPtr; + + ipPtr = (InterpPackage *) clientData; + while (ipPtr != NULL) { + nextPtr = ipPtr->nextPtr; + ckfree((char *) ipPtr); + ipPtr = nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * LoadExitProc -- + * + * This procedure is invoked just before the application exits. + * It frees all of the LoadedPackage structures. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +static void +LoadExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + LoadedPackage *pkgPtr; + + while (firstPackagePtr != NULL) { + pkgPtr = firstPackagePtr; + firstPackagePtr = pkgPtr->nextPtr; + ckfree(pkgPtr->fileName); + ckfree(pkgPtr->packageName); + ckfree((char *) pkgPtr); + } +} diff --git a/tcl/generic/tclLoadNone.c b/tcl/generic/tclLoadNone.c new file mode 100644 index 00000000000..e9975ee1646 --- /dev/null +++ b/tcl/generic/tclLoadNone.c @@ -0,0 +1,82 @@ +/* + * tclLoadNone.c -- + * + * This procedure provides a version of the TclLoadFile for use + * in systems that don't support dynamic loading; it just returns + * an error. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * This procedure is called to carry out dynamic loading of binary + * code; it is intended for use only on systems that don't support + * dynamic loading (it returns an error). + * + * Results: + * The result is TCL_ERROR, and an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + Tcl_SetResult(interp, + "dynamic loading is not currently available on this system", + TCL_STATIC); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/tcl/generic/tclMain.c b/tcl/generic/tclMain.c new file mode 100644 index 00000000000..06069debc25 --- /dev/null +++ b/tcl/generic/tclMain.c @@ -0,0 +1,343 @@ +/* + * tclMain.c -- + * + * Main program for Tcl shells and other Tcl-based applications. + * + * Copyright (c) 1988-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tcl.h" +#include "tclInt.h" + +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT + +/* + * The following code ensures that tclLink.c is linked whenever + * Tcl is linked. Without this code there's no reference to the + * code in that file from anywhere in Tcl, so it may not be + * linked into the application. + */ + +EXTERN int Tcl_LinkVar(); +int (*tclDummyLinkVarPtr)() = Tcl_LinkVar; + +/* + * Declarations for various library procedures and variables (don't want + * to include tclPort.h here, because people might copy this file out of + * the Tcl source directory to make their own modified versions). + * Note: "exit" should really be declared here, but there's no way to + * declare it without causing conflicts with other definitions elsewher + * on some systems, so it's better just to leave it out. + */ + +extern int isatty _ANSI_ARGS_((int fd)); +extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); + +static Tcl_Interp *interp; /* Interpreter for application. */ + +#ifdef TCL_MEM_DEBUG +static char dumpFile[100]; /* Records where to dump memory allocation + * information. */ +static int quitFlag = 0; /* 1 means "checkmem" command was called, + * so the application should quit and dump + * memory allocation information. */ +#endif + +/* + * Forward references for procedures defined later in this file: + */ + +#ifdef TCL_MEM_DEBUG +static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_Main -- + * + * Main program for tclsh and most other Tcl-based applications. + * + * Results: + * None. This procedure never returns (it exits the process when + * it's done. + * + * Side effects: + * This procedure initializes the Tk world and then starts + * interpreting commands; almost anything could happen, depending + * on the script being interpreted. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Main(argc, argv, appInitProc) + int argc; /* Number of arguments. */ + char **argv; /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc; + /* Application-specific initialization + * procedure to call after most + * initialization but before starting to + * execute commands. */ +{ + Tcl_Obj *prompt1NamePtr = NULL; + Tcl_Obj *prompt2NamePtr = NULL; + Tcl_Obj *resultPtr; + Tcl_Obj *commandPtr = NULL; + char buffer[1000], *args, *fileName, *bytes; + int code, gotPartial, tty, length; + int exitCode = 0; + Tcl_Channel inChannel, outChannel, errChannel; + + Tcl_FindExecutable(argv[0]); + interp = Tcl_CreateInterp(); +#ifdef TCL_MEM_DEBUG + Tcl_InitMemory(interp); + Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); +#endif + + /* + * Make command-line arguments available in the Tcl variables "argc" + * and "argv". If the first argument doesn't start with a "-" then + * strip it off and use it as the name of a script file to process. + */ + + fileName = NULL; + if ((argc > 1) && (argv[1][0] != '-')) { + fileName = argv[1]; + argc--; + argv++; + } + args = Tcl_Merge(argc-1, argv+1); + Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); + ckfree(args); + TclFormatInt(buffer, argc-1); + Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], + TCL_GLOBAL_ONLY); + + /* + * Set the "tcl_interactive" variable. + */ + + tty = isatty(0); + Tcl_SetVar(interp, "tcl_interactive", + ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); + + /* + * Invoke application-specific initialization. + */ + + if ((*appInitProc)(interp) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, + "application-specific initialization failed: ", -1); + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + + /* + * If a script file was specified then just source that file + * and quit. + */ + + if (fileName != NULL) { + code = Tcl_EvalFile(interp, fileName); + if (code != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + /* + * The following statement guarantees that the errorInfo + * variable is set properly. + */ + + Tcl_AddErrorInfo(interp, ""); + Tcl_Write(errChannel, + Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1); + Tcl_Write(errChannel, "\n", 1); + } + exitCode = 1; + } + goto done; + } + + /* + * We're running interactively. Source a user-specific startup + * file if the application specified one and if the file exists. + */ + + Tcl_SourceRCFile(interp); + + /* + * Process commands from stdin until there's an end-of-file. Note + * that we need to fetch the standard channels again after every + * eval, since they may have been changed. + */ + + commandPtr = Tcl_NewObj(); + Tcl_IncrRefCount(commandPtr); + prompt1NamePtr = Tcl_NewStringObj("tcl_prompt1", -1); + Tcl_IncrRefCount(prompt1NamePtr); + prompt2NamePtr = Tcl_NewStringObj("tcl_prompt2", -1); + Tcl_IncrRefCount(prompt2NamePtr); + + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + gotPartial = 0; + while (1) { + if (tty) { + Tcl_Obj *promptCmdPtr; + + promptCmdPtr = Tcl_ObjGetVar2(interp, + (gotPartial? prompt2NamePtr : prompt1NamePtr), + (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); + if (promptCmdPtr == NULL) { + defaultPrompt: + if (!gotPartial && outChannel) { + Tcl_Write(outChannel, "% ", 2); + } + } else { + code = Tcl_EvalObj(interp, promptCmdPtr); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (code != TCL_OK) { + if (errChannel) { + resultPtr = Tcl_GetObjResult(interp); + bytes = Tcl_GetStringFromObj(resultPtr, &length); + Tcl_Write(errChannel, bytes, length); + Tcl_Write(errChannel, "\n", 1); + } + Tcl_AddErrorInfo(interp, + "\n (script that generates prompt)"); + goto defaultPrompt; + } + } + if (outChannel) { + Tcl_Flush(outChannel); + } + } + if (!inChannel) { + goto done; + } + length = Tcl_GetsObj(inChannel, commandPtr); + if (length < 0) { + goto done; + } + if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) { + goto done; + } + + /* + * Add the newline removed by Tcl_GetsObj back to the string. + */ + + Tcl_AppendToObj(commandPtr, "\n", 1); + if (!TclObjCommandComplete(commandPtr)) { + gotPartial = 1; + continue; + } + + gotPartial = 0; + code = Tcl_RecordAndEvalObj(interp, commandPtr, 0); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + Tcl_SetObjLength(commandPtr, 0); + if (code != TCL_OK) { + if (errChannel) { + resultPtr = Tcl_GetObjResult(interp); + bytes = Tcl_GetStringFromObj(resultPtr, &length); + Tcl_Write(errChannel, bytes, length); + Tcl_Write(errChannel, "\n", 1); + } + } else if (tty) { + resultPtr = Tcl_GetObjResult(interp); + bytes = Tcl_GetStringFromObj(resultPtr, &length); + if ((length > 0) && outChannel) { + Tcl_Write(outChannel, bytes, length); + Tcl_Write(outChannel, "\n", 1); + } + } +#ifdef TCL_MEM_DEBUG + if (quitFlag) { + Tcl_DecrRefCount(commandPtr); + Tcl_DecrRefCount(prompt1NamePtr); + Tcl_DecrRefCount(prompt2NamePtr); + Tcl_DeleteInterp(interp); + Tcl_Exit(0); + } +#endif + } + + /* + * Rather than calling exit, invoke the "exit" command so that + * users can replace "exit" with some other command to do additional + * cleanup on exit. The Tcl_Eval call should never return. + */ + + done: + if (commandPtr != NULL) { + Tcl_DecrRefCount(commandPtr); + } + if (prompt1NamePtr != NULL) { + Tcl_DecrRefCount(prompt1NamePtr); + } + if (prompt2NamePtr != NULL) { + Tcl_DecrRefCount(prompt2NamePtr); + } + sprintf(buffer, "exit %d", exitCode); + Tcl_Eval(interp, buffer); +} + +/* + *---------------------------------------------------------------------- + * + * CheckmemCmd -- + * + * This is the command procedure for the "checkmem" command, which + * causes the application to exit after printing information about + * memory usage to the file passed to this command as its first + * argument. + * + * Results: + * Returns a standard Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +#ifdef TCL_MEM_DEBUG + + /* ARGSUSED */ +static int +CheckmemCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter for evaluation. */ + int argc; /* Number of arguments. */ + char *argv[]; /* String values of arguments. */ +{ + extern char *tclMemDumpFileName; + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName\"", (char *) NULL); + return TCL_ERROR; + } + strcpy(dumpFile, argv[1]); + tclMemDumpFileName = dumpFile; + quitFlag = 1; + return TCL_OK; +} +#endif diff --git a/tcl/generic/tclMath.h b/tcl/generic/tclMath.h new file mode 100644 index 00000000000..a0de8669d61 --- /dev/null +++ b/tcl/generic/tclMath.h @@ -0,0 +1,27 @@ +/* + * tclMath.h -- + * + * This file is necessary because of Metrowerks CodeWarrior Pro 1 + * on the Macintosh. With 8-byte doubles turned on, the definitions of + * sin, cos, acos, etc., are screwed up. They are fine as long as + * they are used as function calls, but if the function pointers + * are passed around and used, they will crash hard on the 68K. + * + * Copyright (c) 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. + * + * RCS: @(#) $Id$ + */ + +#ifndef _TCLMATH +#define _TCLMATH + +#if defined(MAC_TCL) +# include "tclMacMath.h" +#else +# include <math.h> +#endif + +#endif /* _TCLMATH */ diff --git a/tcl/generic/tclNamesp.c b/tcl/generic/tclNamesp.c new file mode 100644 index 00000000000..97a60029424 --- /dev/null +++ b/tcl/generic/tclNamesp.c @@ -0,0 +1,3889 @@ +/* + * tclNamesp.c -- + * + * Contains support for namespaces, which provide a separate context of + * commands and global variables. The global :: namespace is the + * traditional Tcl "global" scope. Other namespaces are created as + * children of the global namespace. These other namespaces contain + * special-purpose commands and variables for packages. + * + * Copyright (c) 1993-1997 Lucent Technologies. + * Copyright (c) 1997 Sun Microsystems, Inc. + * Copyright (c) 1998 by Scriptics Corporation. + * + * Originally implemented by + * Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * Flag passed to TclGetNamespaceForQualName to indicate that it should + * search for a namespace rather than a command or variable inside a + * namespace. Note that this flag's value must not conflict with the values + * of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, or CREATE_NS_IF_UNKNOWN. + */ + +#define FIND_ONLY_NS 0x1000 + +/* + * Initial sise of stack allocated space for tail list - used when resetting + * shadowed command references in the functin: TclResetShadowedCmdRefs. + */ + +#define NUM_TRAIL_ELEMS 5 + +/* + * Count of the number of namespaces created. This value is used as a + * unique id for each namespace. + */ + +static long numNsCreated = 0; + +/* + * This structure contains a cached pointer to a namespace that is the + * result of resolving the namespace's name in some other namespace. It is + * the internal representation for a nsName object. It contains the + * pointer along with some information that is used to check the cached + * pointer's validity. + */ + +typedef struct ResolvedNsName { + Namespace *nsPtr; /* A cached namespace pointer. */ + long nsId; /* nsPtr's unique namespace id. Used to + * verify that nsPtr is still valid + * (e.g., it's possible that the namespace + * was deleted and a new one created at + * the same address). */ + Namespace *refNsPtr; /* Points to the namespace containing the + * reference (not the namespace that + * contains the referenced namespace). */ + int refCount; /* Reference count: 1 for each nsName + * object that has a pointer to this + * ResolvedNsName structure as its internal + * rep. This structure can be freed when + * refCount becomes zero. */ +} ResolvedNsName; + +/* + * Declarations for procedures local to this file: + */ + +static void DeleteImportedCmd _ANSI_ARGS_(( + ClientData clientData)); +static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, + Tcl_Obj *copyPtr)); +static void FreeNsNameInternalRep _ANSI_ARGS_(( + Tcl_Obj *objPtr)); +static int GetNamespaceFromObj _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr, + Tcl_Namespace **nsPtrPtr)); +static int InvokeImportedCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceChildrenCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceCodeCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceCurrentCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceDeleteCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceEvalCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceExportCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceForgetCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static void NamespaceFree _ANSI_ARGS_((Namespace *nsPtr)); +static int NamespaceImportCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceInscopeCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceOriginCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceParentCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceQualifiersCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceTailCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int NamespaceWhichCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int SetNsNameFromAny _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr)); +static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr)); + +/* + * This structure defines a Tcl object type that contains a + * namespace reference. It is used in commands that take the + * name of a namespace as an argument. The namespace reference + * is resolved, and the result in cached in the object. + */ + +Tcl_ObjType tclNsNameType = { + "nsName", /* the type's name */ + FreeNsNameInternalRep, /* freeIntRepProc */ + DupNsNameInternalRep, /* dupIntRepProc */ + UpdateStringOfNsName, /* updateStringProc */ + SetNsNameFromAny /* setFromAnyProc */ +}; + +/* + * Boolean flag indicating whether or not the namespName object + * type has been registered with the Tcl compiler. + */ + +static int nsInitialized = 0; + +/* + *---------------------------------------------------------------------- + * + * TclInitNamespaces -- + * + * Called when any interpreter is created to make sure that + * things are properly set up for namespaces. + * + * Results: + * None. + * + * Side effects: + * On the first call, the namespName object type is registered + * with the Tcl compiler. + * + *---------------------------------------------------------------------- + */ + +void +TclInitNamespaces() +{ + if (!nsInitialized) { + Tcl_RegisterObjType(&tclNsNameType); + nsInitialized = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCurrentNamespace -- + * + * Returns a pointer to an interpreter's currently active namespace. + * + * Results: + * Returns a pointer to the interpreter's current namespace. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Namespace * +Tcl_GetCurrentNamespace(interp) + register Tcl_Interp *interp; /* Interpreter whose current namespace is + * being queried. */ +{ + register Interp *iPtr = (Interp *) interp; + register Namespace *nsPtr; + + if (iPtr->varFramePtr != NULL) { + nsPtr = iPtr->varFramePtr->nsPtr; + } else { + nsPtr = iPtr->globalNsPtr; + } + return (Tcl_Namespace *) nsPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetGlobalNamespace -- + * + * Returns a pointer to an interpreter's global :: namespace. + * + * Results: + * Returns a pointer to the specified interpreter's global namespace. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Namespace * +Tcl_GetGlobalNamespace(interp) + register Tcl_Interp *interp; /* Interpreter whose global namespace + * should be returned. */ +{ + register Interp *iPtr = (Interp *) interp; + + return (Tcl_Namespace *) iPtr->globalNsPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PushCallFrame -- + * + * Pushes a new call frame onto the interpreter's Tcl call stack. + * Called when executing a Tcl procedure or a "namespace eval" or + * "namespace inscope" command. + * + * Results: + * Returns TCL_OK if successful, or TCL_ERROR (along with an error + * message in the interpreter's result object) if something goes wrong. + * + * Side effects: + * Modifies the interpreter's Tcl call stack. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) + Tcl_Interp *interp; /* Interpreter in which the new call frame + * is to be pushed. */ + Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to + * push. Storage for this have already been + * allocated by the caller; typically this + * is the address of a CallFrame structure + * allocated on the caller's C stack. The + * call frame will be initialized by this + * procedure. The caller can pop the frame + * later with Tcl_PopCallFrame, and it is + * responsible for freeing the frame's + * storage. */ + Tcl_Namespace *namespacePtr; /* Points to the namespace in which the + * frame will execute. If NULL, the + * interpreter's current namespace will + * be used. */ + int isProcCallFrame; /* If nonzero, the frame represents a + * called Tcl procedure and may have local + * vars. Vars will ordinarily be looked up + * in the frame. If new variables are + * created, they will be created in the + * frame. If 0, the frame is for a + * "namespace eval" or "namespace inscope" + * command and var references are treated + * as references to namespace variables. */ +{ + Interp *iPtr = (Interp *) interp; + register CallFrame *framePtr = (CallFrame *) callFramePtr; + register Namespace *nsPtr; + + if (namespacePtr == NULL) { + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } else { + nsPtr = (Namespace *) namespacePtr; + if (nsPtr->flags & NS_DEAD) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "namespace \"", + nsPtr->fullName, "\" not found in context \"", + Tcl_GetCurrentNamespace(interp)->fullName, "\"", + (char *) NULL); + return TCL_ERROR; + } + } + + nsPtr->activationCount++; + framePtr->nsPtr = nsPtr; + framePtr->isProcCallFrame = isProcCallFrame; + framePtr->objc = 0; + framePtr->objv = NULL; + framePtr->callerPtr = iPtr->framePtr; + framePtr->callerVarPtr = iPtr->varFramePtr; + if (iPtr->varFramePtr != NULL) { + framePtr->level = (iPtr->varFramePtr->level + 1); + } else { + framePtr->level = 1; + } + framePtr->procPtr = NULL; /* no called procedure */ + framePtr->varTablePtr = NULL; /* and no local variables */ + framePtr->numCompiledLocals = 0; + framePtr->compiledLocals = NULL; + + /* + * Push the new call frame onto the interpreter's stack of procedure + * call frames making it the current frame. + */ + + iPtr->framePtr = framePtr; + iPtr->varFramePtr = framePtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PopCallFrame -- + * + * Removes a call frame from the Tcl call stack for the interpreter. + * Called to remove a frame previously pushed by Tcl_PushCallFrame. + * + * Results: + * None. + * + * Side effects: + * Modifies the call stack of the interpreter. Resets various fields of + * the popped call frame. If a namespace has been deleted and + * has no more activations on the call stack, the namespace is + * destroyed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_PopCallFrame(interp) + Tcl_Interp* interp; /* Interpreter with call frame to pop. */ +{ + register Interp *iPtr = (Interp *) interp; + register CallFrame *framePtr = iPtr->framePtr; + int saveErrFlag; + Namespace *nsPtr; + + /* + * It's important to remove the call frame from the interpreter's stack + * of call frames before deleting local variables, so that traces + * invoked by the variable deletion don't see the partially-deleted + * frame. + */ + + iPtr->framePtr = framePtr->callerPtr; + iPtr->varFramePtr = framePtr->callerVarPtr; + + /* + * Delete the local variables. As a hack, we save then restore the + * ERR_IN_PROGRESS flag in the interpreter. The problem is that there + * could be unset traces on the variables, which cause scripts to be + * evaluated. This will clear the ERR_IN_PROGRESS flag, losing stack + * trace information if the procedure was exiting with an error. The + * code below preserves the flag. Unfortunately, that isn't really + * enough: we really should preserve the errorInfo variable too + * (otherwise a nested error in the trace script will trash errorInfo). + * What's really needed is a general-purpose mechanism for saving and + * restoring interpreter state. + */ + + saveErrFlag = (iPtr->flags & ERR_IN_PROGRESS); + + if (framePtr->varTablePtr != NULL) { + TclDeleteVars(iPtr, framePtr->varTablePtr); + ckfree((char *) framePtr->varTablePtr); + framePtr->varTablePtr = NULL; + } + if (framePtr->numCompiledLocals > 0) { + TclDeleteCompiledLocalVars(iPtr, framePtr); + } + + iPtr->flags |= saveErrFlag; + + /* + * Decrement the namespace's count of active call frames. If the + * namespace is "dying" and there are no more active call frames, + * call Tcl_DeleteNamespace to destroy it. + */ + + nsPtr = framePtr->nsPtr; + nsPtr->activationCount--; + if ((nsPtr->flags & NS_DYING) + && (nsPtr->activationCount == 0)) { + Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); + } + framePtr->nsPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateNamespace -- + * + * Creates a new namespace with the given name. If there is no + * active namespace (i.e., the interpreter is being initialized), + * the global :: namespace is created and returned. + * + * Results: + * Returns a pointer to the new namespace if successful. If the + * namespace already exists or if another error occurs, this routine + * returns NULL, along with an error message in the interpreter's + * result object. + * + * Side effects: + * If the name contains "::" qualifiers and a parent namespace does + * not already exist, it is automatically created. + * + *---------------------------------------------------------------------- + */ + +Tcl_Namespace * +Tcl_CreateNamespace(interp, name, clientData, deleteProc) + Tcl_Interp *interp; /* Interpreter in which a new namespace + * is being created. Also used for + * error reporting. */ + char *name; /* Name for the new namespace. May be a + * qualified name with names of ancestor + * namespaces separated by "::"s. */ + ClientData clientData; /* One-word value to store with + * namespace. */ + Tcl_NamespaceDeleteProc *deleteProc; + /* Procedure called to delete client + * data when the namespace is deleted. + * NULL if no procedure should be + * called. */ +{ + Interp *iPtr = (Interp *) interp; + register Namespace *nsPtr, *ancestorPtr; + Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; + Namespace *globalNsPtr = iPtr->globalNsPtr; + char *simpleName; + Tcl_HashEntry *entryPtr; + Tcl_DString buffer1, buffer2; + int newEntry, result; + + /* + * If there is no active namespace, the interpreter is being + * initialized. + */ + + if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) { + /* + * Treat this namespace as the global namespace, and avoid + * looking for a parent. + */ + + parentPtr = NULL; + simpleName = ""; + } else if (*name == '\0') { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't create namespace \"\": only global namespace can have empty name", (char *) NULL); + return NULL; + } else { + /* + * Find the parent for the new namespace. + */ + + result = TclGetNamespaceForQualName(interp, name, + (Namespace *) NULL, + /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), + &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); + if (result != TCL_OK) { + return NULL; + } + + /* + * If the unqualified name at the end is empty, there were trailing + * "::"s after the namespace's name which we ignore. The new + * namespace was already (recursively) created and is pointed to + * by parentPtr. + */ + + if (*simpleName == '\0') { + return (Tcl_Namespace *) parentPtr; + } + + /* + * Check for a bad namespace name and make sure that the name + * does not already exist in the parent namespace. + */ + + if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't create namespace \"", name, + "\": already exists", (char *) NULL); + return NULL; + } + } + + /* + * Create the new namespace and root it in its parent. Increment the + * count of namespaces created. + */ + + numNsCreated++; + + nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); + nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); + strcpy(nsPtr->name, simpleName); + nsPtr->fullName = NULL; /* set below */ + nsPtr->clientData = clientData; + nsPtr->deleteProc = deleteProc; + nsPtr->parentPtr = parentPtr; + Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS); + nsPtr->nsId = numNsCreated; + nsPtr->interp = interp; + nsPtr->flags = 0; + nsPtr->activationCount = 0; + nsPtr->refCount = 0; + Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); + nsPtr->exportArrayPtr = NULL; + nsPtr->numExportPatterns = 0; + nsPtr->maxExportPatterns = 0; + nsPtr->cmdRefEpoch = 0; + nsPtr->resolverEpoch = 0; + nsPtr->cmdResProc = NULL; + nsPtr->varResProc = NULL; + nsPtr->compiledVarResProc = NULL; + + if (parentPtr != NULL) { + entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, + &newEntry); + Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); + } + + /* + * Build the fully qualified name for this namespace. + */ + + Tcl_DStringInit(&buffer1); + Tcl_DStringInit(&buffer2); + for (ancestorPtr = nsPtr; ancestorPtr != NULL; + ancestorPtr = ancestorPtr->parentPtr) { + if (ancestorPtr != globalNsPtr) { + Tcl_DStringAppend(&buffer1, "::", 2); + Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1); + } + Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1); + + Tcl_DStringSetLength(&buffer2, 0); + Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1); + Tcl_DStringSetLength(&buffer1, 0); + } + + name = Tcl_DStringValue(&buffer2); + nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1)); + strcpy(nsPtr->fullName, name); + + Tcl_DStringFree(&buffer1); + Tcl_DStringFree(&buffer2); + + /* + * Return a pointer to the new namespace. + */ + + return (Tcl_Namespace *) nsPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteNamespace -- + * + * Deletes a namespace and all of the commands, variables, and other + * namespaces within it. + * + * Results: + * None. + * + * Side effects: + * When a namespace is deleted, it is automatically removed as a + * child of its parent namespace. Also, all its commands, variables + * and child namespaces are deleted. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteNamespace(namespacePtr) + Tcl_Namespace *namespacePtr; /* Points to the namespace to delete. */ +{ + register Namespace *nsPtr = (Namespace *) namespacePtr; + Interp *iPtr = (Interp *) nsPtr->interp; + Namespace *globalNsPtr = + (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); + Tcl_HashEntry *entryPtr; + + /* + * If the namespace is on the call frame stack, it is marked as "dying" + * (NS_DYING is OR'd into its flags): the namespace can't be looked up + * by name but its commands and variables are still usable by those + * active call frames. When all active call frames referring to the + * namespace have been popped from the Tcl stack, Tcl_PopCallFrame will + * call this procedure again to delete everything in the namespace. + * If no nsName objects refer to the namespace (i.e., if its refCount + * is zero), its commands and variables are deleted and the storage for + * its namespace structure is freed. Otherwise, if its refCount is + * nonzero, the namespace's commands and variables are deleted but the + * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's + * flags to allow the namespace resolution code to recognize that the + * namespace is "deleted". The structure's storage is freed by + * FreeNsNameInternalRep when its refCount reaches 0. + */ + + if (nsPtr->activationCount > 0) { + nsPtr->flags |= NS_DYING; + if (nsPtr->parentPtr != NULL) { + entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, + nsPtr->name); + if (entryPtr != NULL) { + Tcl_DeleteHashEntry(entryPtr); + } + } + nsPtr->parentPtr = NULL; + } else { + /* + * Delete the namespace and everything in it. If this is the global + * namespace, then clear it but don't free its storage unless the + * interpreter is being torn down. + */ + + TclTeardownNamespace(nsPtr); + + if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { + /* + * If this is the global namespace, then it may have residual + * "errorInfo" and "errorCode" variables for errors that + * occurred while it was being torn down. Try to clear the + * variable list one last time. + */ + + TclDeleteVars((Interp *) nsPtr->interp, &nsPtr->varTable); + + Tcl_DeleteHashTable(&nsPtr->childTable); + Tcl_DeleteHashTable(&nsPtr->cmdTable); + + /* + * If the reference count is 0, then discard the namespace. + * Otherwise, mark it as "dead" so that it can't be used. + */ + + if (nsPtr->refCount == 0) { + NamespaceFree(nsPtr); + } else { + nsPtr->flags |= NS_DEAD; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclTeardownNamespace -- + * + * Used internally to dismantle and unlink a namespace when it is + * deleted. Divorces the namespace from its parent, and deletes all + * commands, variables, and child namespaces. + * + * This is kept separate from Tcl_DeleteNamespace so that the global + * namespace can be handled specially. Global variables like + * "errorInfo" and "errorCode" need to remain intact while other + * namespaces and commands are torn down, in case any errors occur. + * + * Results: + * None. + * + * Side effects: + * Removes this namespace from its parent's child namespace hashtable. + * Deletes all commands, variables and namespaces in this namespace. + * If this is the global namespace, the "errorInfo" and "errorCode" + * variables are left alone and deleted later. + * + *---------------------------------------------------------------------- + */ + +void +TclTeardownNamespace(nsPtr) + register Namespace *nsPtr; /* Points to the namespace to be dismantled + * and unlinked from its parent. */ +{ + Interp *iPtr = (Interp *) nsPtr->interp; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Tcl_Namespace *childNsPtr; + Tcl_Command cmd; + Namespace *globalNsPtr = + (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); + int i; + + /* + * Start by destroying the namespace's variable table, + * since variables might trigger traces. + */ + + if (nsPtr == globalNsPtr) { + /* + * This is the global namespace, so be careful to preserve the + * "errorInfo" and "errorCode" variables. These might be needed + * later on if errors occur while deleting commands. We are careful + * to destroy and recreate the "errorInfo" and "errorCode" + * variables, in case they had any traces on them. + */ + + char *str, *errorInfoStr, *errorCodeStr; + + str = Tcl_GetVar((Tcl_Interp *) iPtr, "errorInfo", TCL_GLOBAL_ONLY); + if (str != NULL) { + errorInfoStr = ckalloc((unsigned) (strlen(str)+1)); + strcpy(errorInfoStr, str); + } else { + errorInfoStr = NULL; + } + + str = Tcl_GetVar((Tcl_Interp *) iPtr, "errorCode", TCL_GLOBAL_ONLY); + if (str != NULL) { + errorCodeStr = ckalloc((unsigned) (strlen(str)+1)); + strcpy(errorCodeStr, str); + } else { + errorCodeStr = NULL; + } + + TclDeleteVars(iPtr, &nsPtr->varTable); + Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); + + if (errorInfoStr != NULL) { + Tcl_SetVar((Tcl_Interp *) iPtr, "errorInfo", errorInfoStr, + TCL_GLOBAL_ONLY); + ckfree(errorInfoStr); + } + if (errorCodeStr != NULL) { + Tcl_SetVar((Tcl_Interp *) iPtr, "errorCode", errorCodeStr, + TCL_GLOBAL_ONLY); + ckfree(errorCodeStr); + } + } else { + /* + * Variable table should be cleared but not freed! TclDeleteVars + * frees it, so we reinitialize it afterwards. + */ + + TclDeleteVars(iPtr, &nsPtr->varTable); + Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); + } + + /* + * Remove the namespace from its parent's child hashtable. + */ + + if (nsPtr->parentPtr != NULL) { + entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, + nsPtr->name); + if (entryPtr != NULL) { + Tcl_DeleteHashEntry(entryPtr); + } + } + nsPtr->parentPtr = NULL; + + /* + * Delete all the child namespaces. + * + * BE CAREFUL: When each child is deleted, it will divorce + * itself from its parent. You can't traverse a hash table + * properly if its elements are being deleted. We use only + * the Tcl_FirstHashEntry function to be safe. + */ + + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { + childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr); + Tcl_DeleteNamespace(childNsPtr); + } + + /* + * Delete all commands in this namespace. Be careful when traversing the + * hash table: when each command is deleted, it removes itself from the + * command table. + */ + + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + entryPtr != NULL; + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); + } + Tcl_DeleteHashTable(&nsPtr->cmdTable); + Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); + + /* + * Free the namespace's export pattern array. + */ + + if (nsPtr->exportArrayPtr != NULL) { + for (i = 0; i < nsPtr->numExportPatterns; i++) { + ckfree(nsPtr->exportArrayPtr[i]); + } + ckfree((char *) nsPtr->exportArrayPtr); + nsPtr->exportArrayPtr = NULL; + nsPtr->numExportPatterns = 0; + nsPtr->maxExportPatterns = 0; + } + + /* + * Free any client data associated with the namespace. + */ + + if (nsPtr->deleteProc != NULL) { + (*nsPtr->deleteProc)(nsPtr->clientData); + } + nsPtr->deleteProc = NULL; + nsPtr->clientData = NULL; + + /* + * Reset the namespace's id field to ensure that this namespace won't + * be interpreted as valid by, e.g., the cache validation code for + * cached command references in Tcl_GetCommandFromObj. + */ + + nsPtr->nsId = 0; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceFree -- + * + * Called after a namespace has been deleted, when its + * reference count reaches 0. Frees the data structure + * representing the namespace. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +NamespaceFree(nsPtr) + register Namespace *nsPtr; /* Points to the namespace to free. */ +{ + /* + * Most of the namespace's contents are freed when the namespace is + * deleted by Tcl_DeleteNamespace. All that remains is to free its names + * (for error messages), and the structure itself. + */ + + ckfree(nsPtr->name); + ckfree(nsPtr->fullName); + + ckfree((char *) nsPtr); +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_Export -- + * + * Makes all the commands matching a pattern available to later be + * imported from the namespace specified by contextNsPtr (or the + * current namespace if contextNsPtr is NULL). The specified pattern is + * appended onto the namespace's export pattern list, which is + * optionally cleared beforehand. + * + * Results: + * Returns TCL_OK if successful, or TCL_ERROR (along with an error + * message in the interpreter's result) if something goes wrong. + * + * Side effects: + * Appends the export pattern onto the namespace's export list. + * Optionally reset the namespace's export pattern list. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Export(interp, namespacePtr, pattern, resetListFirst) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Namespace *namespacePtr; /* Points to the namespace from which + * commands are to be exported. NULL for + * the current namespace. */ + char *pattern; /* String pattern indicating which commands + * to export. This pattern may not include + * any namespace qualifiers; only commands + * in the specified namespace may be + * exported. */ + int resetListFirst; /* If nonzero, resets the namespace's + * export list before appending + * be overwritten by imported commands. + * If 0, return an error if an imported + * cmd conflicts with an existing one. */ +{ +#define INIT_EXPORT_PATTERNS 5 + Namespace *nsPtr, *exportNsPtr, *dummyPtr; + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + char *simplePattern, *patternCpy; + int neededElems, len, i, result; + + /* + * If the specified namespace is NULL, use the current namespace. + */ + + if (namespacePtr == NULL) { + nsPtr = (Namespace *) currNsPtr; + } else { + nsPtr = (Namespace *) namespacePtr; + } + + /* + * If resetListFirst is true (nonzero), clear the namespace's export + * pattern list. + */ + + if (resetListFirst) { + if (nsPtr->exportArrayPtr != NULL) { + for (i = 0; i < nsPtr->numExportPatterns; i++) { + ckfree(nsPtr->exportArrayPtr[i]); + } + ckfree((char *) nsPtr->exportArrayPtr); + nsPtr->exportArrayPtr = NULL; + nsPtr->numExportPatterns = 0; + nsPtr->maxExportPatterns = 0; + } + } + + /* + * Check that the pattern doesn't have namespace qualifiers. + */ + + result = TclGetNamespaceForQualName(interp, pattern, nsPtr, + /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &dummyPtr, + &dummyPtr, &simplePattern); + if (result != TCL_OK) { + return result; + } + if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid export pattern \"", pattern, + "\": pattern can't specify a namespace", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Make sure there is room in the namespace's pattern array for the + * new pattern. + */ + + neededElems = nsPtr->numExportPatterns + 1; + if (nsPtr->exportArrayPtr == NULL) { + nsPtr->exportArrayPtr = (char **) + ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *))); + nsPtr->numExportPatterns = 0; + nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS; + } else if (neededElems > nsPtr->maxExportPatterns) { + int numNewElems = 2 * nsPtr->maxExportPatterns; + size_t currBytes = nsPtr->numExportPatterns * sizeof(char *); + size_t newBytes = numNewElems * sizeof(char *); + char **newPtr = (char **) ckalloc((unsigned) newBytes); + + memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, + currBytes); + ckfree((char *) nsPtr->exportArrayPtr); + nsPtr->exportArrayPtr = (char **) newPtr; + nsPtr->maxExportPatterns = numNewElems; + } + + /* + * Add the pattern to the namespace's array of export patterns. + */ + + len = strlen(pattern); + patternCpy = (char *) ckalloc((unsigned) (len + 1)); + strcpy(patternCpy, pattern); + + nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; + nsPtr->numExportPatterns++; + return TCL_OK; +#undef INIT_EXPORT_PATTERNS +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendExportList -- + * + * Appends onto the argument object the list of export patterns for the + * specified namespace. + * + * Results: + * The return value is normally TCL_OK; in this case the object + * referenced by objPtr has each export pattern appended to it. If an + * error occurs, TCL_ERROR is returned and the interpreter's result + * holds an error message. + * + * Side effects: + * If necessary, the object referenced by objPtr is converted into + * a list object. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppendExportList(interp, namespacePtr, objPtr) + Tcl_Interp *interp; /* Interpreter used for error reporting. */ + Tcl_Namespace *namespacePtr; /* Points to the namespace whose export + * pattern list is appended onto objPtr. + * NULL for the current namespace. */ + Tcl_Obj *objPtr; /* Points to the Tcl object onto which the + * export pattern list is appended. */ +{ + Namespace *nsPtr; + int i, result; + + /* + * If the specified namespace is NULL, use the current namespace. + */ + + if (namespacePtr == NULL) { + nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(interp); + } else { + nsPtr = (Namespace *) namespacePtr; + } + + /* + * Append the export pattern list onto objPtr. + */ + + for (i = 0; i < nsPtr->numExportPatterns; i++) { + result = Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1)); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Import -- + * + * Imports all of the commands matching a pattern into the namespace + * specified by contextNsPtr (or the current namespace if contextNsPtr + * is NULL). This is done by creating a new command (the "imported + * command") that points to the real command in its original namespace. + * + * If matching commands are on the autoload path but haven't been + * loaded yet, this command forces them to be loaded, then creates + * the links to them. + * + * Results: + * Returns TCL_OK if successful, or TCL_ERROR (along with an error + * message in the interpreter's result) if something goes wrong. + * + * Side effects: + * Creates new commands in the importing namespace. These indirect + * calls back to the real command and are deleted if the real commands + * are deleted. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Namespace *namespacePtr; /* Points to the namespace into which the + * commands are to be imported. NULL for + * the current namespace. */ + char *pattern; /* String pattern indicating which commands + * to import. This pattern should be + * qualified by the name of the namespace + * from which to import the command(s). */ + int allowOverwrite; /* If nonzero, allow existing commands to + * be overwritten by imported commands. + * If 0, return an error if an imported + * cmd conflicts with an existing one. */ +{ + Interp *iPtr = (Interp *) interp; + Namespace *nsPtr, *importNsPtr, *dummyPtr; + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + char *simplePattern, *cmdName; + register Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Command *cmdPtr; + ImportRef *refPtr; + Tcl_Command autoCmd, importedCmd; + ImportedCmdData *dataPtr; + int wasExported, i, result; + + /* + * If the specified namespace is NULL, use the current namespace. + */ + + if (namespacePtr == NULL) { + nsPtr = (Namespace *) currNsPtr; + } else { + nsPtr = (Namespace *) namespacePtr; + } + + /* + * First, invoke the "auto_import" command with the pattern + * being imported. This command is part of the Tcl library. + * It looks for imported commands in autoloaded libraries and + * loads them in. That way, they will be found when we try + * to create links below. + */ + + autoCmd = Tcl_FindCommand(interp, "auto_import", + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + + if (autoCmd != NULL) { + Tcl_Obj *objv[2]; + + objv[0] = Tcl_NewStringObj("auto_import", -1); + Tcl_IncrRefCount(objv[0]); + objv[1] = Tcl_NewStringObj(pattern, -1); + Tcl_IncrRefCount(objv[1]); + + cmdPtr = (Command *) autoCmd; + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, + 2, objv); + + Tcl_DecrRefCount(objv[0]); + Tcl_DecrRefCount(objv[1]); + + if (result != TCL_OK) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + } + + /* + * From the pattern, find the namespace from which we are importing + * and get the simple pattern (no namespace qualifiers or ::'s) at + * the end. + */ + + if (strlen(pattern) == 0) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "empty import pattern", -1); + return TCL_ERROR; + } + result = TclGetNamespaceForQualName(interp, pattern, nsPtr, + /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr, + &dummyPtr, &simplePattern); + if (result != TCL_OK) { + return TCL_ERROR; + } + if (importNsPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown namespace in import pattern \"", + pattern, "\"", (char *) NULL); + return TCL_ERROR; + } + if (importNsPtr == nsPtr) { + if (pattern == simplePattern) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "no namespace specified in import pattern \"", pattern, + "\"", (char *) NULL); + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "import pattern \"", pattern, + "\" tries to import from namespace \"", + importNsPtr->name, "\" into itself", (char *) NULL); + } + return TCL_ERROR; + } + + /* + * Scan through the command table in the source namespace and look for + * exported commands that match the string pattern. Create an "imported + * command" in the current namespace for each imported command; these + * commands redirect their invocations to the "real" command. + */ + + for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); + (hPtr != NULL); + hPtr = Tcl_NextHashEntry(&search)) { + cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); + if (Tcl_StringMatch(cmdName, simplePattern)) { + /* + * The command cmdName in the source namespace matches the + * pattern. Check whether it was exported. If it wasn't, + * we ignore it. + */ + + wasExported = 0; + for (i = 0; i < importNsPtr->numExportPatterns; i++) { + if (Tcl_StringMatch(cmdName, + importNsPtr->exportArrayPtr[i])) { + wasExported = 1; + break; + } + } + if (!wasExported) { + continue; + } + + /* + * Unless there is a name clash, create an imported command + * in the current namespace that refers to cmdPtr. + */ + + if ((Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) + || allowOverwrite) { + /* + * Create the imported command and its client data. + * To create the new command in the current namespace, + * generate a fully qualified name for it. + */ + + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + if (nsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&ds, "::", 2); + } + Tcl_DStringAppend(&ds, cmdName, -1); + + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + dataPtr = (ImportedCmdData *) + ckalloc(sizeof(ImportedCmdData)); + importedCmd = Tcl_CreateObjCommand(interp, + Tcl_DStringValue(&ds), InvokeImportedCmd, + (ClientData) dataPtr, DeleteImportedCmd); + dataPtr->realCmdPtr = cmdPtr; + dataPtr->selfPtr = (Command *) importedCmd; + + /* + * Create an ImportRef structure describing this new import + * command and add it to the import ref list in the "real" + * command. + */ + + refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); + refPtr->importedCmdPtr = (Command *) importedCmd; + refPtr->nextPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = refPtr; + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't import command \"", cmdName, + "\": already exists", (char *) NULL); + return TCL_ERROR; + } + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ForgetImport -- + * + * Deletes previously imported commands. Given a pattern that may + * include the name of an exporting namespace, this procedure first + * finds all matching exported commands. It then looks in the namespace + * specified by namespacePtr for any corresponding previously imported + * commands, which it deletes. If namespacePtr is NULL, commands are + * deleted from the current namespace. + * + * Results: + * Returns TCL_OK if successful. If there is an error, returns + * TCL_ERROR and puts an error message in the interpreter's result + * object. + * + * Side effects: + * May delete commands. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ForgetImport(interp, namespacePtr, pattern) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Namespace *namespacePtr; /* Points to the namespace from which + * previously imported commands should be + * removed. NULL for current namespace. */ + char *pattern; /* String pattern indicating which imported + * commands to remove. This pattern should + * be qualified by the name of the + * namespace from which the command(s) were + * imported. */ +{ + Namespace *nsPtr, *importNsPtr, *dummyPtr, *actualCtxPtr; + char *simplePattern, *cmdName; + register Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Command *cmdPtr; + int result; + + /* + * If the specified namespace is NULL, use the current namespace. + */ + + if (namespacePtr == NULL) { + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } else { + nsPtr = (Namespace *) namespacePtr; + } + + /* + * From the pattern, find the namespace from which we are importing + * and get the simple pattern (no namespace qualifiers or ::'s) at + * the end. + */ + + result = TclGetNamespaceForQualName(interp, pattern, nsPtr, + /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr, + &actualCtxPtr, &simplePattern); + if (result != TCL_OK) { + return result; + } + if (importNsPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown namespace in namespace forget pattern \"", + pattern, "\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Scan through the command table in the source namespace and look for + * exported commands that match the string pattern. If the current + * namespace has an imported command that refers to one of those real + * commands, delete it. + */ + + for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); + (hPtr != NULL); + hPtr = Tcl_NextHashEntry(&search)) { + cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); + if (Tcl_StringMatch(cmdName, simplePattern)) { + hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); + if (hPtr != NULL) { /* cmd of same name in current namespace */ + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (cmdPtr->deleteProc == DeleteImportedCmd) { + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + } + } + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetOriginalCommand -- + * + * An imported command is created in an namespace when it imports a + * "real" command from another namespace. If the specified command is a + * imported command, this procedure returns the original command it + * refers to. + * + * Results: + * If the command was imported into a sequence of namespaces a, b,...,n + * where each successive namespace just imports the command from the + * previous namespace, this procedure returns the Tcl_Command token in + * the first namespace, a. Otherwise, if the specified command is not + * an imported command, the procedure returns NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclGetOriginalCommand(command) + Tcl_Command command; /* The command for which the original + * command should be returned. */ +{ + register Command *cmdPtr = (Command *) command; + ImportedCmdData *dataPtr; + + if (cmdPtr->deleteProc != DeleteImportedCmd) { + return (Tcl_Command) NULL; + } + + while (cmdPtr->deleteProc == DeleteImportedCmd) { + dataPtr = (ImportedCmdData *) cmdPtr->objClientData; + cmdPtr = dataPtr->realCmdPtr; + } + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * InvokeImportedCmd -- + * + * Invoked by Tcl whenever the user calls an imported command that + * was created by Tcl_Import. Finds the "real" command (in another + * namespace), and passes control to it. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Returns a result in the interpreter's result object. If anything + * goes wrong, the result object is set to an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InvokeImportedCmd(clientData, interp, objc, objv) + ClientData clientData; /* Points to the imported command's + * ImportedCmdData structure. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; + register Command *realCmdPtr = dataPtr->realCmdPtr; + + return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, + objc, objv); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteImportedCmd -- + * + * Invoked by Tcl whenever an imported command is deleted. The "real" + * command keeps a list of all the imported commands that refer to it, + * so those imported commands can be deleted when the real command is + * deleted. This procedure removes the imported command reference from + * the real command's list, and frees up the memory associated with + * the imported command. + * + * Results: + * None. + * + * Side effects: + * Removes the imported command from the real command's import list. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteImportedCmd(clientData) + ClientData clientData; /* Points to the imported command's + * ImportedCmdData structure. */ +{ + ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; + Command *realCmdPtr = dataPtr->realCmdPtr; + Command *selfPtr = dataPtr->selfPtr; + register ImportRef *refPtr, *prevPtr; + + prevPtr = NULL; + for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; + refPtr = refPtr->nextPtr) { + if (refPtr->importedCmdPtr == selfPtr) { + /* + * Remove *refPtr from real command's list of imported commands + * that refer to it. + */ + + if (prevPtr == NULL) { /* refPtr is first in list */ + realCmdPtr->importRefPtr = refPtr->nextPtr; + } else { + prevPtr->nextPtr = refPtr->nextPtr; + } + ckfree((char *) refPtr); + ckfree((char *) dataPtr); + return; + } + prevPtr = refPtr; + } + + panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references"); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetNamespaceForQualName -- + * + * Given a qualified name specifying a command, variable, or namespace, + * and a namespace in which to resolve the name, this procedure returns + * a pointer to the namespace that contains the item. A qualified name + * consists of the "simple" name of an item qualified by the names of + * an arbitrary number of containing namespace separated by "::"s. If + * the qualified name starts with "::", it is interpreted absolutely + * from the global namespace. Otherwise, it is interpreted relative to + * the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr + * is NULL, the name is interpreted relative to the current namespace. + * + * A relative name like "foo::bar::x" can be found starting in either + * the current namespace or in the global namespace. So each search + * usually follows two tracks, and two possible namespaces are + * returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to + * NULL, then that path failed. + * + * If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is + * sought only in the global :: namespace. The alternate search + * (also) starting from the global namespace is ignored and + * *altNsPtrPtr is set NULL. + * + * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified + * name is sought only in the namespace specified by cxtNsPtr. The + * alternate search starting from the global namespace is ignored and + * *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and + * TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and + * the search starts from the namespace specified by cxtNsPtr. + * + * If "flags" contains CREATE_NS_IF_UNKNOWN, all namespace + * components of the qualified name that cannot be found are + * automatically created within their specified parent. This makes sure + * that functions like Tcl_CreateCommand always succeed. There is no + * alternate search path, so *altNsPtrPtr is set NULL. + * + * If "flags" contains FIND_ONLY_NS, the qualified name is treated as a + * reference to a namespace, and the entire qualified name is + * followed. If the name is relative, the namespace is looked up only + * in the current namespace. A pointer to the namespace is stored in + * *nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if + * FIND_ONLY_NS is not specified, only the leading components are + * treated as namespace names, and a pointer to the simple name of the + * final component is stored in *simpleNamePtr. + * + * Results: + * Ordinarily this procedure returns TCL_OK. It sets *nsPtrPtr and + * *altNsPtrPtr to point to the two possible namespaces which represent + * the last (containing) namespace in the qualified name. If the + * procedure sets either *nsPtrPtr or *altNsPtrPtr to NULL, then the + * search along that path failed. The procedure also stores a pointer + * to the simple name of the final component in *simpleNamePtr. If the + * qualified name is "::" or was treated as a namespace reference + * (FIND_ONLY_NS), the procedure stores a pointer to the + * namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets + * *simpleNamePtr to point to an empty string. + * + * If there is an error, this procedure returns TCL_ERROR. If "flags" + * contains TCL_LEAVE_ERR_MSG, an error message is returned in the + * interpreter's result object. Otherwise, the interpreter's result + * object is left unchanged. + * + * *actualCxtPtrPtr is set to the actual context namespace. It is + * set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr + * is NULL, it is set to the current namespace context. + * + * Side effects: + * If flags contains TCL_LEAVE_ERR_MSG and an error is encountered, + * the interpreter's result object will contain an error message. + * + *---------------------------------------------------------------------- + */ + +int +TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, + nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) + Tcl_Interp *interp; /* Interpreter in which to find the + * namespace containing qualName. */ + register char *qualName; /* A namespace-qualified name of an + * command, variable, or namespace. */ + Namespace *cxtNsPtr; /* The namespace in which to start the + * search for qualName's namespace. If NULL + * start from the current namespace. + * Ignored if TCL_GLOBAL_ONLY or + * TCL_NAMESPACE_ONLY are set. */ + int flags; /* Flags controlling the search: an OR'd + * combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, + * CREATE_NS_IF_UNKNOWN, and + * FIND_ONLY_NS. */ + Namespace **nsPtrPtr; /* Address where procedure stores a pointer + * to containing namespace if qualName is + * found starting from *cxtNsPtr or, if + * TCL_GLOBAL_ONLY is set, if qualName is + * found in the global :: namespace. NULL + * is stored otherwise. */ + Namespace **altNsPtrPtr; /* Address where procedure stores a pointer + * to containing namespace if qualName is + * found starting from the global :: + * namespace. NULL is stored if qualName + * isn't found starting from :: or if the + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * CREATE_NS_IF_UNKNOWN, FIND_ONLY_NS flag + * is set. */ + Namespace **actualCxtPtrPtr; /* Address where procedure stores a pointer + * to the actual namespace from which the + * search started. This is either cxtNsPtr, + * the :: namespace if TCL_GLOBAL_ONLY was + * specified, or the current namespace if + * cxtNsPtr was NULL. */ + char **simpleNamePtr; /* Address where procedure stores the + * simple name at end of the qualName, or + * NULL if qualName is "::" or the flag + * FIND_ONLY_NS was specified. */ +{ + Interp *iPtr = (Interp *) interp; + Namespace *nsPtr = cxtNsPtr; + Namespace *altNsPtr; + Namespace *globalNsPtr = iPtr->globalNsPtr; + register char *start, *end; + char *nsName; + Tcl_HashEntry *entryPtr; + Tcl_DString buffer; + int len, result; + + /* + * Determine the context namespace nsPtr in which to start the primary + * search. If TCL_NAMESPACE_ONLY or FIND_ONLY_NS was specified, search + * from the current namespace. If the qualName name starts with a "::" + * or TCL_GLOBAL_ONLY was specified, search from the global + * namespace. Otherwise, use the given namespace given in cxtNsPtr, or + * if that is NULL, use the current namespace context. Note that we + * always treat two or more adjacent ":"s as a namespace separator. + */ + + if (flags & (TCL_NAMESPACE_ONLY | FIND_ONLY_NS)) { + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } else if (flags & TCL_GLOBAL_ONLY) { + nsPtr = globalNsPtr; + } else if (nsPtr == NULL) { + if (iPtr->varFramePtr != NULL) { + nsPtr = iPtr->varFramePtr->nsPtr; + } else { + nsPtr = iPtr->globalNsPtr; + } + } + + start = qualName; /* pts to start of qualifying namespace */ + if ((*qualName == ':') && (*(qualName+1) == ':')) { + start = qualName+2; /* skip over the initial :: */ + while (*start == ':') { + start++; /* skip over a subsequent : */ + } + nsPtr = globalNsPtr; + if (*start == '\0') { /* qualName is just two or more ":"s */ + *nsPtrPtr = globalNsPtr; + *altNsPtrPtr = NULL; + *actualCxtPtrPtr = globalNsPtr; + *simpleNamePtr = start; /* points to empty string */ + return TCL_OK; + } + } + *actualCxtPtrPtr = nsPtr; + + /* + * Start an alternate search path starting with the global namespace. + * However, if the starting context is the global namespace, or if the + * flag is set to search only the namespace *cxtNsPtr, ignore the + * alternate search path. + */ + + altNsPtr = globalNsPtr; + if ((nsPtr == globalNsPtr) + || (flags & (TCL_NAMESPACE_ONLY | FIND_ONLY_NS))) { + altNsPtr = NULL; + } + + /* + * Loop to resolve each namespace qualifier in qualName. + */ + + Tcl_DStringInit(&buffer); + end = start; + while (*start != '\0') { + /* + * Find the next namespace qualifier (i.e., a name ending in "::") + * or the end of the qualified name (i.e., a name ending in "\0"). + * Set len to the number of characters, starting from start, + * in the name; set end to point after the "::"s or at the "\0". + */ + + len = 0; + for (end = start; *end != '\0'; end++) { + if ((*end == ':') && (*(end+1) == ':')) { + end += 2; /* skip over the initial :: */ + while (*end == ':') { + end++; /* skip over the subsequent : */ + } + break; /* exit for loop; end is after ::'s */ + } + len++; + } + + if ((*end == '\0') + && !((end-start >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) { + /* + * qualName ended with a simple name at start. If FIND_ONLY_NS + * was specified, look this up as a namespace. Otherwise, + * start is the name of a cmd or var and we are done. + */ + + if (flags & FIND_ONLY_NS) { + nsName = start; + } else { + *nsPtrPtr = nsPtr; + *altNsPtrPtr = altNsPtr; + *simpleNamePtr = start; + Tcl_DStringFree(&buffer); + return TCL_OK; + } + } else { + /* + * start points to the beginning of a namespace qualifier ending + * in "::". end points to the start of a name in that namespace + * that might be empty. Copy the namespace qualifier to a + * buffer so it can be null terminated. We can't modify the + * incoming qualName since it may be a string constant. + */ + + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, start, len); + nsName = Tcl_DStringValue(&buffer); + } + + /* + * Look up the namespace qualifier nsName in the current namespace + * context. If it isn't found but CREATE_NS_IF_UNKNOWN is set, + * create that qualifying namespace. This is needed for procedures + * like Tcl_CreateCommand that cannot fail. + */ + + if (nsPtr != NULL) { + entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); + if (entryPtr != NULL) { + nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); + } else if (flags & CREATE_NS_IF_UNKNOWN) { + Tcl_CallFrame frame; + + result = Tcl_PushCallFrame(interp, &frame, + (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); + if (result != TCL_OK) { + Tcl_DStringFree(&buffer); + return result; + } + nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, + (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); + Tcl_PopCallFrame(interp); + if (nsPtr == NULL) { + Tcl_DStringFree(&buffer); + return TCL_ERROR; + } + } else { /* namespace not found and wasn't created */ + nsPtr = NULL; + } + } + + /* + * Look up the namespace qualifier in the alternate search path too. + */ + + if (altNsPtr != NULL) { + entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName); + if (entryPtr != NULL) { + altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); + } else { + altNsPtr = NULL; + } + } + + /* + * If both search paths have failed, return NULL results. + */ + + if ((nsPtr == NULL) && (altNsPtr == NULL)) { + *nsPtrPtr = NULL; + *altNsPtrPtr = NULL; + *simpleNamePtr = NULL; + Tcl_DStringFree(&buffer); + return TCL_OK; + } + + start = end; + } + + /* + * We ignore trailing "::"s in a namespace name, but in a command or + * variable name, trailing "::"s refer to the cmd or var named {}. + */ + + if ((flags & FIND_ONLY_NS) + || ((end > start ) && (*(end-1) != ':'))) { + *simpleNamePtr = NULL; /* found namespace name */ + } else { + *simpleNamePtr = end; /* found cmd/var: points to empty string */ + } + + /* + * As a special case, if we are looking for a namespace and qualName + * is "" and the current active namespace (nsPtr) is not the global + * namespace, return NULL (no namespace was found). This is because + * namespaces can not have empty names except for the global namespace. + */ + + if ((flags & FIND_ONLY_NS) && (*qualName == '\0') + && (nsPtr != globalNsPtr)) { + nsPtr = NULL; + } + + *nsPtrPtr = nsPtr; + *altNsPtrPtr = altNsPtr; + Tcl_DStringFree(&buffer); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindNamespace -- + * + * Searches for a namespace. + * + * Results: + * Returns a pointer to the namespace if it is found. Otherwise, + * returns NULL and leaves an error message in the interpreter's + * result object if "flags" contains TCL_LEAVE_ERR_MSG. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Namespace * +Tcl_FindNamespace(interp, name, contextNsPtr, flags) + Tcl_Interp *interp; /* The interpreter in which to find the + * namespace. */ + char *name; /* Namespace name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set + * or if the name starts with "::". + * Otherwise, points to namespace in which + * to resolve name; if NULL, look up name + * in the current namespace. */ + register int flags; /* Flags controlling namespace lookup: an + * OR'd combination of TCL_GLOBAL_ONLY and + * TCL_LEAVE_ERR_MSG flags. */ +{ + Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; + char *dummy; + int result; + + /* + * Find the namespace(s) that contain the specified namespace name. + * Add the FIND_ONLY_NS flag to resolve the name all the way down + * to its last component, a namespace. + */ + + result = TclGetNamespaceForQualName(interp, name, + (Namespace *) contextNsPtr, /*flags*/ (flags | FIND_ONLY_NS), + &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + if (result != TCL_OK) { + return NULL; + } + if (nsPtr != NULL) { + return (Tcl_Namespace *) nsPtr; + } else if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown namespace \"", name, "\"", (char *) NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindCommand -- + * + * Searches for a command. + * + * Results: + * Returns a token for the command if it is found. Otherwise, if it + * can't be found or there is an error, returns NULL and leaves an + * error message in the interpreter's result object if "flags" + * contains TCL_LEAVE_ERR_MSG. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_FindCommand(interp, name, contextNsPtr, flags) + Tcl_Interp *interp; /* The interpreter in which to find the + * command and to report errors. */ + char *name; /* Command's name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. + * Otherwise, points to namespace in which + * to resolve name. If NULL, look up name + * in the current namespace. */ + int flags; /* An OR'd combination of flags: + * TCL_GLOBAL_ONLY (look up name only in + * global namespace), TCL_NAMESPACE_ONLY + * (look up only in contextNsPtr, or the + * current namespace if contextNsPtr is + * NULL), and TCL_LEAVE_ERR_MSG. If both + * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY + * are given, TCL_GLOBAL_ONLY is + * ignored. */ +{ + Interp *iPtr = (Interp*)interp; + + ResolverScheme *resPtr; + Namespace *nsPtr[2], *cxtNsPtr; + char *simpleName; + register Tcl_HashEntry *entryPtr; + register Command *cmdPtr; + register int search; + int result; + Tcl_Command cmd; + + /* + * If this namespace has a command resolver, then give it first + * crack at the command resolution. If the interpreter has any + * command resolvers, consult them next. The command resolver + * procedures may return a Tcl_Command value, they may signal + * to continue onward, or they may signal an error. + */ + if ((flags & TCL_GLOBAL_ONLY) != 0) { + cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + } + else if (contextNsPtr != NULL) { + cxtNsPtr = (Namespace *) contextNsPtr; + } + else { + cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } + + if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { + resPtr = iPtr->resolverPtr; + + if (cxtNsPtr->cmdResProc) { + result = (*cxtNsPtr->cmdResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &cmd); + } else { + result = TCL_CONTINUE; + } + + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->cmdResProc) { + result = (*resPtr->cmdResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &cmd); + } + resPtr = resPtr->nextPtr; + } + + if (result == TCL_OK) { + return cmd; + } + else if (result != TCL_CONTINUE) { + return (Tcl_Command) NULL; + } + } + + /* + * Find the namespace(s) that contain the command. + */ + + result = TclGetNamespaceForQualName(interp, name, + (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], + &cxtNsPtr, &simpleName); + if (result != TCL_OK) { + return (Tcl_Command) NULL; + } + + /* + * Look for the command in the command table of its namespace. + * Be sure to check both possible search paths: from the specified + * namespace context and from the global namespace. + */ + + cmdPtr = NULL; + for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { + if ((nsPtr[search] != NULL) && (simpleName != NULL)) { + entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, + simpleName); + if (entryPtr != NULL) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + } + } + } + if (cmdPtr != NULL) { + return (Tcl_Command) cmdPtr; + } else if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown command \"", name, "\"", (char *) NULL); + } + + return (Tcl_Command) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindNamespaceVar -- + * + * Searches for a namespace variable, a variable not local to a + * procedure. The variable can be either a scalar or an array, but + * may not be an element of an array. + * + * Results: + * Returns a token for the variable if it is found. Otherwise, if it + * can't be found or there is an error, returns NULL and leaves an + * error message in the interpreter's result object if "flags" + * contains TCL_LEAVE_ERR_MSG. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Var +Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) + Tcl_Interp *interp; /* The interpreter in which to find the + * variable. */ + char *name; /* Variable's name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. + * Otherwise, points to namespace in which + * to resolve name. If NULL, look up name + * in the current namespace. */ + int flags; /* An OR'd combination of flags: + * TCL_GLOBAL_ONLY (look up name only in + * global namespace), TCL_NAMESPACE_ONLY + * (look up only in contextNsPtr, or the + * current namespace if contextNsPtr is + * NULL), and TCL_LEAVE_ERR_MSG. If both + * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY + * are given, TCL_GLOBAL_ONLY is + * ignored. */ +{ + Interp *iPtr = (Interp*)interp; + ResolverScheme *resPtr; + Namespace *nsPtr[2], *cxtNsPtr; + char *simpleName; + Tcl_HashEntry *entryPtr; + Var *varPtr; + register int search; + int result; + Tcl_Var var; + + /* + * If this namespace has a variable resolver, then give it first + * crack at the variable resolution. It may return a Tcl_Var + * value, it may signal to continue onward, or it may signal + * an error. + */ + if ((flags & TCL_GLOBAL_ONLY) != 0) { + cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + } + else if (contextNsPtr != NULL) { + cxtNsPtr = (Namespace *) contextNsPtr; + } + else { + cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } + + if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + resPtr = iPtr->resolverPtr; + + if (cxtNsPtr->varResProc) { + result = (*cxtNsPtr->varResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } else { + result = TCL_CONTINUE; + } + + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->varResProc) { + result = (*resPtr->varResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } + resPtr = resPtr->nextPtr; + } + + if (result == TCL_OK) { + return var; + } + else if (result != TCL_CONTINUE) { + return (Tcl_Var) NULL; + } + } + + /* + * Find the namespace(s) that contain the variable. + */ + + result = TclGetNamespaceForQualName(interp, name, + (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], + &cxtNsPtr, &simpleName); + if (result != TCL_OK) { + return (Tcl_Var) NULL; + } + + /* + * Look for the variable in the variable table of its namespace. + * Be sure to check both possible search paths: from the specified + * namespace context and from the global namespace. + */ + + varPtr = NULL; + for (search = 0; (search < 2) && (varPtr == NULL); search++) { + if ((nsPtr[search] != NULL) && (simpleName != NULL)) { + entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, + simpleName); + if (entryPtr != NULL) { + varPtr = (Var *) Tcl_GetHashValue(entryPtr); + } + } + } + if (varPtr != NULL) { + return (Tcl_Var) varPtr; + } else if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown variable \"", name, "\"", (char *) NULL); + } + return (Tcl_Var) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclResetShadowedCmdRefs -- + * + * Called when a command is added to a namespace to check for existing + * command references that the new command may invalidate. Consider the + * following cases that could happen when you add a command "foo" to a + * namespace "b": + * 1. It could shadow a command named "foo" at the global scope. + * If it does, all command references in the namespace "b" are + * suspect. + * 2. Suppose the namespace "b" resides in a namespace "a". + * Then to "a" the new command "b::foo" could shadow another + * command "b::foo" in the global namespace. If so, then all + * command references in "a" are suspect. + * The same checks are applied to all parent namespaces, until we + * reach the global :: namespace. + * + * Results: + * None. + * + * Side effects: + * If the new command shadows an existing command, the cmdRefEpoch + * counter is incremented in each namespace that sees the shadow. + * This invalidates all command references that were previously cached + * in that namespace. The next time the commands are used, they are + * resolved from scratch. + * + *---------------------------------------------------------------------- + */ + +void +TclResetShadowedCmdRefs(interp, newCmdPtr) + Tcl_Interp *interp; /* Interpreter containing the new command. */ + Command *newCmdPtr; /* Points to the new command. */ +{ + char *cmdName; + Tcl_HashEntry *hPtr; + register Namespace *nsPtr; + Namespace *trailNsPtr, *shadowNsPtr; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + int found, i; + + /* + * This procedure generates an array used to hold the trail list. This + * starts out with stack-allocated space but uses dynamically-allocated + * storage if needed. + */ + + Namespace *(trailStorage[NUM_TRAIL_ELEMS]); + Namespace **trailPtr = trailStorage; + int trailFront = -1; + int trailSize = NUM_TRAIL_ELEMS; + + /* + * Start at the namespace containing the new command, and work up + * through the list of parents. Stop just before the global namespace, + * since the global namespace can't "shadow" its own entries. + * + * The namespace "trail" list we build consists of the names of each + * namespace that encloses the new command, in order from outermost to + * innermost: for example, "a" then "b". Each iteration of this loop + * eventually extends the trail upwards by one namespace, nsPtr. We use + * this trail list to see if nsPtr (e.g. "a" in 2. above) could have + * now-invalid cached command references. This will happen if nsPtr + * (e.g. "a") contains a sequence of child namespaces (e.g. "b") + * such that there is a identically-named sequence of child namespaces + * starting from :: (e.g. "::b") whose tail namespace contains a command + * also named cmdName. + */ + + cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr); + for (nsPtr = newCmdPtr->nsPtr; + (nsPtr != NULL) && (nsPtr != globalNsPtr); + nsPtr = nsPtr->parentPtr) { + /* + * Find the maximal sequence of child namespaces contained in nsPtr + * such that there is a identically-named sequence of child + * namespaces starting from ::. shadowNsPtr will be the tail of this + * sequence, or the deepest namespace under :: that might contain a + * command now shadowed by cmdName. We check below if shadowNsPtr + * actually contains a command cmdName. + */ + + found = 1; + shadowNsPtr = globalNsPtr; + + for (i = trailFront; i >= 0; i--) { + trailNsPtr = trailPtr[i]; + hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, + trailNsPtr->name); + if (hPtr != NULL) { + shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr); + } else { + found = 0; + break; + } + } + + /* + * If shadowNsPtr contains a command named cmdName, we invalidate + * all of the command refs cached in nsPtr. As a boundary case, + * shadowNsPtr is initially :: and we check for case 1. above. + */ + + if (found) { + hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); + if (hPtr != NULL) { + nsPtr->cmdRefEpoch++; + } + } + + /* + * Insert nsPtr at the front of the trail list: i.e., at the end + * of the trailPtr array. + */ + + trailFront++; + if (trailFront == trailSize) { + size_t currBytes = trailSize * sizeof(Namespace *); + int newSize = 2*trailSize; + size_t newBytes = newSize * sizeof(Namespace *); + Namespace **newPtr = + (Namespace **) ckalloc((unsigned) newBytes); + + memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes); + if (trailPtr != trailStorage) { + ckfree((char *) trailPtr); + } + trailPtr = newPtr; + trailSize = newSize; + } + trailPtr[trailFront] = nsPtr; + } + + /* + * Free any allocated storage. + */ + + if (trailPtr != trailStorage) { + ckfree((char *) trailPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * GetNamespaceFromObj -- + * + * Returns the namespace specified by the name in a Tcl_Obj. + * + * Results: + * Returns TCL_OK if the namespace was resolved successfully, and + * stores a pointer to the namespace in the location specified by + * nsPtrPtr. If the namespace can't be found, the procedure stores + * NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong, + * this procedure returns TCL_ERROR. + * + * Side effects: + * May update the internal representation for the object, caching the + * namespace reference. The next time this procedure is called, the + * namespace value can be found quickly. + * + * If anything goes wrong, an error message is left in the + * interpreter's result object. + * + *---------------------------------------------------------------------- + */ + +static int +GetNamespaceFromObj(interp, objPtr, nsPtrPtr) + Tcl_Interp *interp; /* The current interpreter. */ + Tcl_Obj *objPtr; /* The object to be resolved as the name + * of a namespace. */ + Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */ +{ + register ResolvedNsName *resNamePtr; + register Namespace *nsPtr; + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + int result; + + /* + * Get the internal representation, converting to a namespace type if + * needed. The internal representation is a ResolvedNsName that points + * to the actual namespace. + */ + + if (objPtr->typePtr != &tclNsNameType) { + result = tclNsNameType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + return TCL_ERROR; + } + } + resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; + + /* + * Check the context namespace of the resolved symbol to make sure that + * it is fresh. If not, then force another conversion to the namespace + * type, to discard the old rep and create a new one. Note that we + * verify that the namespace id of the cached namespace is the same as + * the id when we cached it; this insures that the namespace wasn't + * deleted and a new one created at the same address. + */ + + nsPtr = NULL; + if ((resNamePtr != NULL) + && (resNamePtr->refNsPtr == currNsPtr) + && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { + nsPtr = resNamePtr->nsPtr; + if (nsPtr->flags & NS_DEAD) { + nsPtr = NULL; + } + } + if (nsPtr == NULL) { /* try again */ + result = tclNsNameType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + return TCL_ERROR; + } + resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; + if (resNamePtr != NULL) { + nsPtr = resNamePtr->nsPtr; + if (nsPtr->flags & NS_DEAD) { + nsPtr = NULL; + } + } + } + *nsPtrPtr = (Tcl_Namespace *) nsPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NamespaceObjCmd -- + * + * Invoked to implement the "namespace" command that creates, deletes, + * or manipulates Tcl namespaces. Handles the following syntax: + * + * namespace children ?name? ?pattern? + * namespace code arg + * namespace current + * namespace delete ?name name...? + * namespace eval name arg ?arg...? + * namespace export ?-clear? ?pattern pattern...? + * namespace forget ?pattern pattern...? + * namespace import ?-force? ?pattern pattern...? + * namespace inscope name arg ?arg...? + * namespace origin name + * namespace parent ?name? + * namespace qualifiers string + * namespace tail string + * namespace which ?-command? ?-variable? name + * + * Results: + * Returns TCL_OK if the command is successful. Returns TCL_ERROR if + * anything goes wrong. + * + * Side effects: + * Based on the subcommand name (e.g., "import"), this procedure + * dispatches to a corresponding procedure NamespaceXXXCmd defined + * statically in this file. This procedure's side effects depend on + * whatever that subcommand procedure does. If there is an error, this + * procedure returns an error message in the interpreter's result + * object. Otherwise it may return a result in the interpreter's result + * object. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_NamespaceObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp; /* Current interpreter. */ + register int objc; /* Number of arguments. */ + register Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + static char *subCmds[] = { + "children", "code", "current", "delete", + "eval", "export", "forget", "import", + "inscope", "origin", "parent", "qualifiers", + "tail", "which", (char *) NULL}; + enum NSSubCmdIdx { + NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, + NSEvalIdx, NSExportIdx, NSForgetIdx, NSImportIdx, + NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx, + NSTailIdx, NSWhichIdx + } index; + int result; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); + return TCL_ERROR; + } + + /* + * Return an index reflecting the particular subcommand. + */ + + result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds, + "option", /*flags*/ 0, (int *) &index); + if (result != TCL_OK) { + return result; + } + + switch (index) { + case NSChildrenIdx: + result = NamespaceChildrenCmd(clientData, interp, objc, objv); + break; + case NSCodeIdx: + result = NamespaceCodeCmd(clientData, interp, objc, objv); + break; + case NSCurrentIdx: + result = NamespaceCurrentCmd(clientData, interp, objc, objv); + break; + case NSDeleteIdx: + result = NamespaceDeleteCmd(clientData, interp, objc, objv); + break; + case NSEvalIdx: + result = NamespaceEvalCmd(clientData, interp, objc, objv); + break; + case NSExportIdx: + result = NamespaceExportCmd(clientData, interp, objc, objv); + break; + case NSForgetIdx: + result = NamespaceForgetCmd(clientData, interp, objc, objv); + break; + case NSImportIdx: + result = NamespaceImportCmd(clientData, interp, objc, objv); + break; + case NSInscopeIdx: + result = NamespaceInscopeCmd(clientData, interp, objc, objv); + break; + case NSOriginIdx: + result = NamespaceOriginCmd(clientData, interp, objc, objv); + break; + case NSParentIdx: + result = NamespaceParentCmd(clientData, interp, objc, objv); + break; + case NSQualifiersIdx: + result = NamespaceQualifiersCmd(clientData, interp, objc, objv); + break; + case NSTailIdx: + result = NamespaceTailCmd(clientData, interp, objc, objv); + break; + case NSWhichIdx: + result = NamespaceWhichCmd(clientData, interp, objc, objv); + break; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceChildrenCmd -- + * + * Invoked to implement the "namespace children" command that returns a + * list containing the fully-qualified names of the child namespaces of + * a given namespace. Handles the following syntax: + * + * namespace children ?name? ?pattern? + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Returns a result in the interpreter's result object. If anything + * goes wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceChildrenCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Namespace *namespacePtr; + Namespace *nsPtr, *childNsPtr; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + char *pattern = NULL; + Tcl_DString buffer; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Tcl_Obj *listPtr, *elemPtr; + + /* + * Get a pointer to the specified namespace, or the current namespace. + */ + + if (objc == 2) { + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } else if ((objc == 3) || (objc == 4)) { + if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { + return TCL_ERROR; + } + if (namespacePtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown namespace \"", + Tcl_GetStringFromObj(objv[2], (int *) NULL), + "\" in namespace children command", (char *) NULL); + return TCL_ERROR; + } + nsPtr = (Namespace *) namespacePtr; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); + return TCL_ERROR; + } + + /* + * Get the glob-style pattern, if any, used to narrow the search. + */ + + Tcl_DStringInit(&buffer); + if (objc == 4) { + char *name = Tcl_GetStringFromObj(objv[3], (int *) NULL); + + if ((*name == ':') && (*(name+1) == ':')) { + pattern = name; + } else { + Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); + if (nsPtr != globalNsPtr) { + Tcl_DStringAppend(&buffer, "::", 2); + } + Tcl_DStringAppend(&buffer, name, -1); + pattern = Tcl_DStringValue(&buffer); + } + } + + /* + * Create a list containing the full names of all child namespaces + * whose names match the specified pattern, if any. + */ + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + while (entryPtr != NULL) { + childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); + if ((pattern == NULL) + || Tcl_StringMatch(childNsPtr->fullName, pattern)) { + elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); + Tcl_ListObjAppendElement(interp, listPtr, elemPtr); + } + entryPtr = Tcl_NextHashEntry(&search); + } + + Tcl_SetObjResult(interp, listPtr); + Tcl_DStringFree(&buffer); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceCodeCmd -- + * + * Invoked to implement the "namespace code" command to capture the + * namespace context of a command. Handles the following syntax: + * + * namespace code arg + * + * Here "arg" can be a list. "namespace code arg" produces a result + * equivalent to that produced by the command + * + * list namespace inscope [namespace current] $arg + * + * However, if "arg" is itself a scoped value starting with + * "namespace inscope", then the result is just "arg". + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter's result object. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceCodeCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Namespace *currNsPtr; + Tcl_Obj *listPtr, *objPtr; + register char *arg, *p; + int length; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arg"); + return TCL_ERROR; + } + + /* + * If "arg" is already a scoped value, then return it directly. + */ + + arg = Tcl_GetStringFromObj(objv[2], &length); + if ((*arg == 'n') && (length > 17) + && (strncmp(arg, "namespace", 9) == 0)) { + for (p = (arg + 9); (*p == ' '); p++) { + /* empty body: skip over spaces */ + } + if ((*p == 'i') && ((p + 7) <= (arg + length)) + && (strncmp(p, "inscope", 7) == 0)) { + Tcl_SetObjResult(interp, objv[2]); + return TCL_OK; + } + } + + /* + * Otherwise, construct a scoped command by building a list with + * "namespace inscope", the full name of the current namespace, and + * the argument "arg". By constructing a list, we ensure that scoped + * commands are interpreted properly when they are executed later, + * by the "namespace inscope" command. + */ + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("namespace", -1)); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("inscope", -1)); + + currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { + objPtr = Tcl_NewStringObj("::", -1); + } else { + objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + + Tcl_ListObjAppendElement(interp, listPtr, objv[2]); + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceCurrentCmd -- + * + * Invoked to implement the "namespace current" command which returns + * the fully-qualified name of the current namespace. Handles the + * following syntax: + * + * namespace current + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Returns a result in the interpreter's result object. If anything + * goes wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceCurrentCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Namespace *currNsPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + + /* + * The "real" name of the global namespace ("::") is the null string, + * but we return "::" for it as a convenience to programmers. Note that + * "" and "::" are treated as synonyms by the namespace code so that it + * is still easy to do things like: + * + * namespace [namespace current]::bar { ... } + */ + + currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), "::", -1); + } else { + Tcl_AppendToObj(Tcl_GetObjResult(interp), currNsPtr->fullName, -1); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceDeleteCmd -- + * + * Invoked to implement the "namespace delete" command to delete + * namespace(s). Handles the following syntax: + * + * namespace delete ?name name...? + * + * Each name identifies a namespace. It may include a sequence of + * namespace qualifiers separated by "::"s. If a namespace is found, it + * is deleted: all variables and procedures contained in that namespace + * are deleted. If that namespace is being used on the call stack, it + * is kept alive (but logically deleted) until it is removed from the + * call stack: that is, it can no longer be referenced by name but any + * currently executing procedure that refers to it is allowed to do so + * until the procedure returns. If the namespace can't be found, this + * procedure returns an error. If no namespaces are specified, this + * command does nothing. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Deletes the specified namespaces. If anything goes wrong, this + * procedure returns an error message in the interpreter's + * result object. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceDeleteCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Namespace *namespacePtr; + char *name; + register int i; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); + return TCL_ERROR; + } + + /* + * Destroying one namespace may cause another to be destroyed. Break + * this into two passes: first check to make sure that all namespaces on + * the command line are valid, and report any errors. + */ + + for (i = 2; i < objc; i++) { + name = Tcl_GetStringFromObj(objv[i], (int *) NULL); + namespacePtr = Tcl_FindNamespace(interp, name, + (Tcl_Namespace *) NULL, /*flags*/ 0); + if (namespacePtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown namespace \"", + Tcl_GetStringFromObj(objv[i], (int *) NULL), + "\" in namespace delete command", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * Okay, now delete each namespace. + */ + + for (i = 2; i < objc; i++) { + name = Tcl_GetStringFromObj(objv[i], (int *) NULL); + namespacePtr = Tcl_FindNamespace(interp, name, + (Tcl_Namespace *) NULL, /* flags */ 0); + if (namespacePtr) { + Tcl_DeleteNamespace(namespacePtr); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceEvalCmd -- + * + * Invoked to implement the "namespace eval" command. Executes + * commands in a namespace. If the namespace does not already exist, + * it is created. Handles the following syntax: + * + * namespace eval name arg ?arg...? + * + * If more than one arg argument is specified, the command that is + * executed is the result of concatenating the arguments together with + * a space between each argument. + * + * Results: + * Returns TCL_OK if the namespace is found and the commands are + * executed successfully. Returns TCL_ERROR if anything goes wrong. + * + * Side effects: + * Returns the result of the command in the interpreter's result + * object. If anything goes wrong, this procedure returns an error + * message as the result. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceEvalCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Namespace *namespacePtr; + Tcl_CallFrame frame; + Tcl_Obj *objPtr; + char *name; + int length, result; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); + return TCL_ERROR; + } + + /* + * Try to resolve the namespace reference, caching the result in the + * namespace object along the way. + */ + + result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); + if (result != TCL_OK) { + return result; + } + + /* + * If the namespace wasn't found, try to create it. + */ + + if (namespacePtr == NULL) { + name = Tcl_GetStringFromObj(objv[2], &length); + namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, + (Tcl_NamespaceDeleteProc *) NULL); + if (namespacePtr == NULL) { + return TCL_ERROR; + } + } + + /* + * Make the specified namespace the current namespace and evaluate + * the command(s). + */ + + result = Tcl_PushCallFrame(interp, &frame, namespacePtr, + /*isProcCallFrame*/ 0); + if (result != TCL_OK) { + return TCL_ERROR; + } + + if (objc == 4) { + result = Tcl_EvalObj(interp, objv[3]); + } else { + objPtr = Tcl_ConcatObj(objc-3, objv+3); + result = Tcl_EvalObj(interp, objPtr); + Tcl_DecrRefCount(objPtr); /* we're done with the object */ + } + if (result == TCL_ERROR) { + char msg[256]; + + sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)", + namespacePtr->fullName, interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + + /* + * Restore the previous "current" namespace. + */ + + Tcl_PopCallFrame(interp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceExportCmd -- + * + * Invoked to implement the "namespace export" command that specifies + * which commands are exported from a namespace. The exported commands + * are those that can be imported into another namespace using + * "namespace import". Both commands defined in a namespace and + * commands the namespace has imported can be exported by a + * namespace. This command has the following syntax: + * + * namespace export ?-clear? ?pattern pattern...? + * + * Each pattern may contain "string match"-style pattern matching + * special characters, but the pattern may not include any namespace + * qualifiers: that is, the pattern must specify commands in the + * current (exporting) namespace. The specified patterns are appended + * onto the namespace's list of export patterns. + * + * To reset the namespace's export pattern list, specify the "-clear" + * flag. + * + * If there are no export patterns and the "-clear" flag isn't given, + * this command returns the namespace's current export list. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Returns a result in the interpreter's result object. If anything + * goes wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceExportCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp); + char *pattern, *string; + int resetListFirst = 0; + int firstArg, patternCt, i, result; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-clear? ?pattern pattern...?"); + return TCL_ERROR; + } + + /* + * Process the optional "-clear" argument. + */ + + firstArg = 2; + if (firstArg < objc) { + string = Tcl_GetStringFromObj(objv[firstArg], (int *) NULL); + if (strcmp(string, "-clear") == 0) { + resetListFirst = 1; + firstArg++; + } + } + + /* + * If no pattern arguments are given, and "-clear" isn't specified, + * return the namespace's current export pattern list. + */ + + patternCt = (objc - firstArg); + if (patternCt == 0) { + if (firstArg > 2) { + return TCL_OK; + } else { /* create list with export patterns */ + Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + result = Tcl_AppendExportList(interp, + (Tcl_Namespace *) currNsPtr, listPtr); + if (result != TCL_OK) { + return result; + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + } + + /* + * Add each pattern to the namespace's export pattern list. + */ + + for (i = firstArg; i < objc; i++) { + pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL); + result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, + ((i == firstArg)? resetListFirst : 0)); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceForgetCmd -- + * + * Invoked to implement the "namespace forget" command to remove + * imported commands from a namespace. Handles the following syntax: + * + * namespace forget ?pattern pattern...? + * + * Each pattern is a name like "foo::*" or "a::b::x*". That is, the + * pattern may include the special pattern matching characters + * recognized by the "string match" command, but only in the command + * name at the end of the qualified name; the special pattern + * characters may not appear in a namespace name. All of the commands + * that match that pattern are checked to see if they have an imported + * command in the current namespace that refers to the matched + * command. If there is an alias, it is removed. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Imported commands are removed from the current namespace. If + * anything goes wrong, this procedure returns an error message in the + * interpreter's result object. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceForgetCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *pattern; + register int i, result; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); + return TCL_ERROR; + } + + for (i = 2; i < objc; i++) { + pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL); + result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceImportCmd -- + * + * Invoked to implement the "namespace import" command that imports + * commands into a namespace. Handles the following syntax: + * + * namespace import ?-force? ?pattern pattern...? + * + * Each pattern is a namespace-qualified name like "foo::*", + * "a::b::x*", or "bar::p". That is, the pattern may include the + * special pattern matching characters recognized by the "string match" + * command, but only in the command name at the end of the qualified + * name; the special pattern characters may not appear in a namespace + * name. All of the commands that match the pattern and which are + * exported from their namespace are made accessible from the current + * namespace context. This is done by creating a new "imported command" + * in the current namespace that points to the real command in its + * original namespace; when the imported command is called, it invokes + * the real command. + * + * If an imported command conflicts with an existing command, it is + * treated as an error. But if the "-force" option is included, then + * existing commands are overwritten by the imported commands. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Adds imported commands to the current namespace. If anything goes + * wrong, this procedure returns an error message in the interpreter's + * result object. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceImportCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int allowOverwrite = 0; + char *string, *pattern; + register int i, result; + int firstArg; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-force? ?pattern pattern...?"); + return TCL_ERROR; + } + + /* + * Skip over the optional "-force" as the first argument. + */ + + firstArg = 2; + if (firstArg < objc) { + string = Tcl_GetStringFromObj(objv[firstArg], (int *) NULL); + if ((*string == '-') && (strcmp(string, "-force") == 0)) { + allowOverwrite = 1; + firstArg++; + } + } + + /* + * Handle the imports for each of the patterns. + */ + + for (i = firstArg; i < objc; i++) { + pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL); + result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern, + allowOverwrite); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceInscopeCmd -- + * + * Invoked to implement the "namespace inscope" command that executes a + * script in the context of a particular namespace. This command is not + * expected to be used directly by programmers; calls to it are + * generated implicitly when programs use "namespace code" commands + * to register callback scripts. Handles the following syntax: + * + * namespace inscope name arg ?arg...? + * + * The "namespace inscope" command is much like the "namespace eval" + * command except that it has lappend semantics and the namespace must + * already exist. It treats the first argument as a list, and appends + * any arguments after the first onto the end as proper list elements. + * For example, + * + * namespace inscope ::foo a b c d + * + * is equivalent to + * + * namespace eval ::foo [concat a [list b c d]] + * + * This lappend semantics is important because many callback scripts + * are actually prefixes. + * + * Results: + * Returns TCL_OK to indicate success, or TCL_ERROR to indicate + * failure. + * + * Side effects: + * Returns a result in the Tcl interpreter's result object. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceInscopeCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Namespace *namespacePtr; + Tcl_CallFrame frame; + int i, result; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); + return TCL_ERROR; + } + + /* + * Resolve the namespace reference. + */ + + result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); + if (result != TCL_OK) { + return result; + } + if (namespacePtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown namespace \"", + Tcl_GetStringFromObj(objv[2], (int *) NULL), + "\" in inscope namespace command", (char *) NULL); + return TCL_ERROR; + } + + /* + * Make the specified namespace the current namespace. + */ + + result = Tcl_PushCallFrame(interp, &frame, namespacePtr, + /*isProcCallFrame*/ 0); + if (result != TCL_OK) { + return result; + } + + /* + * Execute the command. If there is just one argument, just treat it as + * a script and evaluate it. Otherwise, create a list from the arguments + * after the first one, then concatenate the first argument and the list + * of extra arguments to form the command to evaluate. + */ + + if (objc == 4) { + result = Tcl_EvalObj(interp, objv[3]); + } else { + Tcl_Obj *concatObjv[2]; + register Tcl_Obj *listPtr, *cmdObjPtr; + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + for (i = 4; i < objc; i++) { + result = Tcl_ListObjAppendElement(interp, listPtr, objv[i]); + if (result != TCL_OK) { + Tcl_DecrRefCount(listPtr); /* free unneeded obj */ + return result; + } + } + + concatObjv[0] = objv[3]; + concatObjv[1] = listPtr; + cmdObjPtr = Tcl_ConcatObj(2, concatObjv); + result = Tcl_EvalObj(interp, cmdObjPtr); + + Tcl_DecrRefCount(cmdObjPtr); /* we're done with the cmd object */ + Tcl_DecrRefCount(listPtr); /* we're done with the list object */ + } + if (result == TCL_ERROR) { + char msg[256]; + + sprintf(msg, + "\n (in namespace inscope \"%.200s\" script line %d)", + namespacePtr->fullName, interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + + /* + * Restore the previous "current" namespace. + */ + + Tcl_PopCallFrame(interp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceOriginCmd -- + * + * Invoked to implement the "namespace origin" command to return the + * fully-qualified name of the "real" command to which the specified + * "imported command" refers. Handles the following syntax: + * + * namespace origin name + * + * Results: + * An imported command is created in an namespace when that namespace + * imports a command from another namespace. If a command is imported + * into a sequence of namespaces a, b,...,n where each successive + * namespace just imports the command from the previous namespace, this + * command returns the fully-qualified name of the original command in + * the first namespace, a. If "name" does not refer to an alias, its + * fully-qualified name is returned. The returned name is stored in the + * interpreter's result object. This procedure returns TCL_OK if + * successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error message in + * the interpreter's result object. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceOriginCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Command command, origCommand; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; + } + + command = Tcl_GetCommandFromObj(interp, objv[2]); + if (command == (Tcl_Command) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", + Tcl_GetStringFromObj(objv[2], (int *) NULL), + "\"", (char *) NULL); + return TCL_ERROR; + } + origCommand = TclGetOriginalCommand(command); + if (origCommand == (Tcl_Command) NULL) { + /* + * The specified command isn't an imported command. Return the + * command's name qualified by the full name of the namespace it + * was defined in. + */ + + Tcl_GetCommandFullName(interp, command, Tcl_GetObjResult(interp)); + } else { + Tcl_GetCommandFullName(interp, origCommand, Tcl_GetObjResult(interp)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceParentCmd -- + * + * Invoked to implement the "namespace parent" command that returns the + * fully-qualified name of the parent namespace for a specified + * namespace. Handles the following syntax: + * + * namespace parent ?name? + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Returns a result in the interpreter's result object. If anything + * goes wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceParentCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Namespace *nsPtr; + int result; + + if (objc == 2) { + nsPtr = Tcl_GetCurrentNamespace(interp); + } else if (objc == 3) { + result = GetNamespaceFromObj(interp, objv[2], &nsPtr); + if (result != TCL_OK) { + return result; + } + if (nsPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown namespace \"", + Tcl_GetStringFromObj(objv[2], (int *) NULL), + "\" in namespace parent command", (char *) NULL); + return TCL_ERROR; + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?name?"); + return TCL_ERROR; + } + + /* + * Report the parent of the specified namespace. + */ + + if (nsPtr->parentPtr != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), + nsPtr->parentPtr->fullName, -1); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceQualifiersCmd -- + * + * Invoked to implement the "namespace qualifiers" command that returns + * any leading namespace qualifiers in a string. These qualifiers are + * namespace names separated by "::"s. For example, for "::foo::p" this + * command returns "::foo", and for "::" it returns "". This command + * is the complement of the "namespace tail" command. Note that this + * command does not check whether the "namespace" names are, in fact, + * the names of currently defined namespaces. Handles the following + * syntax: + * + * namespace qualifiers string + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Returns a result in the interpreter's result object. If anything + * goes wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceQualifiersCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register char *name, *p; + int length; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "string"); + return TCL_ERROR; + } + + /* + * Find the end of the string, then work backward and find + * the start of the last "::" qualifier. + */ + + name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + for (p = name; *p != '\0'; p++) { + /* empty body */ + } + while (--p >= name) { + if ((*p == ':') && (p > name) && (*(p-1) == ':')) { + p -= 2; /* back up over the :: */ + while ((p >= name) && (*p == ':')) { + p--; /* back up over the preceeding : */ + } + break; + } + } + + if (p >= name) { + length = p-name+1; + Tcl_AppendToObj(Tcl_GetObjResult(interp), name, length); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceTailCmd -- + * + * Invoked to implement the "namespace tail" command that returns the + * trailing name at the end of a string with "::" namespace + * qualifiers. These qualifiers are namespace names separated by + * "::"s. For example, for "::foo::p" this command returns "p", and for + * "::" it returns "". This command is the complement of the "namespace + * qualifiers" command. Note that this command does not check whether + * the "namespace" names are, in fact, the names of currently defined + * namespaces. Handles the following syntax: + * + * namespace tail string + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Returns a result in the interpreter's result object. If anything + * goes wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceTailCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register char *name, *p; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "string"); + return TCL_ERROR; + } + + /* + * Find the end of the string, then work backward and find the + * last "::" qualifier. + */ + + name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + for (p = name; *p != '\0'; p++) { + /* empty body */ + } + while (--p > name) { + if ((*p == ':') && (*(p-1) == ':')) { + p++; /* just after the last "::" */ + break; + } + } + + if (p >= name) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), p, -1); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceWhichCmd -- + * + * Invoked to implement the "namespace which" command that returns the + * fully-qualified name of a command or variable. If the specified + * command or variable does not exist, it returns "". Handles the + * following syntax: + * + * namespace which ?-command? ?-variable? name + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Returns a result in the interpreter's result object. If anything + * goes wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceWhichCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register char *arg; + Tcl_Command cmd; + Tcl_Var variable; + int argIndex, lookup; + + if (objc < 3) { + badArgs: + Tcl_WrongNumArgs(interp, 2, objv, + "?-command? ?-variable? name"); + return TCL_ERROR; + } + + /* + * Look for a flag controlling the lookup. + */ + + argIndex = 2; + lookup = 0; /* assume command lookup by default */ + arg = Tcl_GetStringFromObj(objv[2], (int *) NULL); + if (*arg == '-') { + if (strncmp(arg, "-command", 8) == 0) { + lookup = 0; + } else if (strncmp(arg, "-variable", 9) == 0) { + lookup = 1; + } else { + goto badArgs; + } + argIndex = 3; + } + if (objc != (argIndex + 1)) { + goto badArgs; + } + + switch (lookup) { + case 0: /* -command */ + cmd = Tcl_GetCommandFromObj(interp, objv[argIndex]); + if (cmd == (Tcl_Command) NULL) { + return TCL_OK; /* cmd not found, just return (no error) */ + } + Tcl_GetCommandFullName(interp, cmd, Tcl_GetObjResult(interp)); + break; + + case 1: /* -variable */ + arg = Tcl_GetStringFromObj(objv[argIndex], (int *) NULL); + variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL, + /*flags*/ 0); + if (variable != (Tcl_Var) NULL) { + Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp)); + } + break; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FreeNsNameInternalRep -- + * + * Frees the resources associated with a nsName object's internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Decrements the ref count of any Namespace structure pointed + * to by the nsName's internal representation. If there are no more + * references to the namespace, it's structure will be freed. + * + *---------------------------------------------------------------------- + */ + +static void +FreeNsNameInternalRep(objPtr) + register Tcl_Obj *objPtr; /* nsName object with internal + * representation to free */ +{ + register ResolvedNsName *resNamePtr = + (ResolvedNsName *) objPtr->internalRep.otherValuePtr; + Namespace *nsPtr; + + /* + * Decrement the reference count of the namespace. If there are no + * more references, free it up. + */ + + if (resNamePtr != NULL) { + resNamePtr->refCount--; + if (resNamePtr->refCount == 0) { + + /* + * Decrement the reference count for the cached namespace. If + * the namespace is dead, and there are no more references to + * it, free it. + */ + + nsPtr = resNamePtr->nsPtr; + nsPtr->refCount--; + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + NamespaceFree(nsPtr); + } + ckfree((char *) resNamePtr); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * DupNsNameInternalRep -- + * + * Initializes the internal representation of a nsName object to a copy + * of the internal representation of another nsName object. + * + * Results: + * None. + * + * Side effects: + * copyPtr's internal rep is set to refer to the same namespace + * referenced by srcPtr's internal rep. Increments the ref count of + * the ResolvedNsName structure used to hold the namespace reference. + * + *---------------------------------------------------------------------- + */ + +static void +DupNsNameInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + register ResolvedNsName *resNamePtr = + (ResolvedNsName *) srcPtr->internalRep.otherValuePtr; + + copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; + if (resNamePtr != NULL) { + resNamePtr->refCount++; + } + copyPtr->typePtr = &tclNsNameType; +} + +/* + *---------------------------------------------------------------------- + * + * SetNsNameFromAny -- + * + * Attempt to generate a nsName internal representation for a + * Tcl object. + * + * Results: + * Returns TCL_OK if the value could be converted to a proper + * namespace reference. Otherwise, it returns TCL_ERROR, along + * with an error message in the interpreter's result object. + * + * Side effects: + * If successful, the object is made a nsName object. Its internal rep + * is set to point to a ResolvedNsName, which contains a cached pointer + * to the Namespace. Reference counts are kept on both the + * ResolvedNsName and the Namespace, so we can keep track of their + * usage and free them when appropriate. + * + *---------------------------------------------------------------------- + */ + +static int +SetNsNameFromAny(interp, objPtr) + Tcl_Interp *interp; /* Points to the namespace in which to + * resolve name. Also used for error + * reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *name, *dummy; + Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; + register ResolvedNsName *resNamePtr; + int flags, result; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + name = objPtr->bytes; + if (name == NULL) { + name = Tcl_GetStringFromObj(objPtr, (int *) NULL); + } + + /* + * Look for the namespace "name" in the current namespace. If there is + * an error parsing the (possibly qualified) name, return an error. + * If the namespace isn't found, we convert the object to an nsName + * object with a NULL ResolvedNsName* internal rep. + */ + + flags = ((interp != NULL)? TCL_LEAVE_ERR_MSG : 0) | FIND_ONLY_NS; + result = TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, + flags, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + if (result != TCL_OK) { + return result; + } + + /* + * If we found a namespace, then create a new ResolvedNsName structure + * that holds a reference to it. + */ + + if (nsPtr != NULL) { + Namespace *currNsPtr = + (Namespace *) Tcl_GetCurrentNamespace(interp); + + nsPtr->refCount++; + resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); + resNamePtr->nsPtr = nsPtr; + resNamePtr->nsId = nsPtr->nsId; + resNamePtr->refNsPtr = currNsPtr; + resNamePtr->refCount = 1; + } else { + resNamePtr = NULL; + } + + /* + * Free the old internalRep before setting the new one. + * We do this as late as possible to allow the conversion code + * (in particular, Tcl_GetStringFromObj) to use that old internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; + objPtr->typePtr = &tclNsNameType; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfNsName -- + * + * Updates the string representation for a nsName object. + * Note: This procedure does not free an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a copy of the fully qualified + * namespace name. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfNsName(objPtr) + register Tcl_Obj *objPtr; /* nsName object with string rep to update. */ +{ + ResolvedNsName *resNamePtr = + (ResolvedNsName *) objPtr->internalRep.otherValuePtr; + register Namespace *nsPtr; + char *name = ""; + int length; + + if ((resNamePtr != NULL) + && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { + nsPtr = resNamePtr->nsPtr; + if (nsPtr->flags & NS_DEAD) { + nsPtr = NULL; + } + if (nsPtr != NULL) { + name = nsPtr->fullName; + } + } + + /* + * The following sets the string rep to an empty string on the heap + * if the internal rep is NULL. + */ + + length = strlen(name); + if (length == 0) { + objPtr->bytes = tclEmptyStringRep; + } else { + objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); + memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length); + objPtr->bytes[length] = '\0'; + } + objPtr->length = length; +} diff --git a/tcl/generic/tclNotify.c b/tcl/generic/tclNotify.c new file mode 100644 index 00000000000..67bf7bfa4e1 --- /dev/null +++ b/tcl/generic/tclNotify.c @@ -0,0 +1,880 @@ +/* + * tclNotify.c -- + * + * This file implements the generic portion of the Tcl notifier. + * The notifier is lowest-level part of the event system. It + * manages an event queue that holds Tcl_Event structures. The + * platform specific portion of the notifier is defined in the + * tcl*Notify.c files in each platform directory. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright (c) 1998 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following static indicates whether this module has been initialized. + */ + +static int initialized = 0; + +/* + * For each event source (created with Tcl_CreateEventSource) there + * is a structure of the following type: + */ + +typedef struct EventSource { + Tcl_EventSetupProc *setupProc; + Tcl_EventCheckProc *checkProc; + ClientData clientData; + struct EventSource *nextPtr; +} EventSource; + +/* + * The following structure keeps track of the state of the notifier. + * The first three elements keep track of the event queue. In addition to + * the first (next to be serviced) and last events in the queue, we keep + * track of a "marker" event. This provides a simple priority mechanism + * whereby events can be inserted at the front of the queue but behind all + * other high-priority events already in the queue (this is used for things + * like a sequence of Enter and Leave events generated during a grab in + * Tk). + */ + +static struct { + Tcl_Event *firstEventPtr; /* First pending event, or NULL if none. */ + Tcl_Event *lastEventPtr; /* Last pending event, or NULL if none. */ + Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or + * NULL if none. */ + int serviceMode; /* One of TCL_SERVICE_NONE or + * TCL_SERVICE_ALL. */ + int blockTimeSet; /* 0 means there is no maximum block + * time: block forever. */ + Tcl_Time blockTime; /* If blockTimeSet is 1, gives the + * maximum elapsed time for the next block. */ + int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being + * called during an event source traversal. */ + EventSource *firstEventSourcePtr; + /* Pointer to first event source in + * global list of event sources. */ +} notifier; + +/* + * Declarations for functions used in this file. + */ + +static void InitNotifier _ANSI_ARGS_((void)); +static void NotifierExitHandler _ANSI_ARGS_((ClientData clientData)); + + +/* + *---------------------------------------------------------------------- + * + * InitNotifier -- + * + * This routine is called to initialize the notifier module. + * + * Results: + * None. + * + * Side effects: + * Creates an exit handler and initializes static data. + * + *---------------------------------------------------------------------- + */ + +static void +InitNotifier() +{ + initialized = 1; + memset(¬ifier, 0, sizeof(notifier)); + notifier.serviceMode = TCL_SERVICE_NONE; + Tcl_CreateExitHandler(NotifierExitHandler, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * NotifierExitHandler -- + * + * This routine is called during Tcl finalization. + * + * Results: + * None. + * + * Side effects: + * Clears the notifier intialization flag. + * + *---------------------------------------------------------------------- + */ + +static void +NotifierExitHandler(clientData) + ClientData clientData; /* Not used. */ +{ + initialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateEventSource -- + * + * This procedure is invoked to create a new source of events. + * The source is identified by a procedure that gets invoked + * during Tcl_DoOneEvent to check for events on that source + * and queue them. + * + * + * Results: + * None. + * + * Side effects: + * SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent + * runs out of things to do. SetupProc will be invoked before + * Tcl_DoOneEvent calls select or whatever else it uses to wait + * for events. SetupProc typically calls functions like Tcl_WatchFile + * or Tcl_SetMaxBlockTime to indicate what to wait for. + * + * CheckProc is called after select or whatever operation was actually + * used to wait. It figures out whether anything interesting actually + * happened (e.g. by calling Tcl_FileReady), and then calls + * Tcl_QueueEvent to queue any events that are ready. + * + * Each of these procedures is passed two arguments, e.g. + * (*checkProc)(ClientData clientData, int flags)); + * ClientData is the same as the clientData argument here, and flags + * is a combination of things like TCL_FILE_EVENTS that indicates + * what events are of interest: setupProc and checkProc use flags + * to figure out whether their events are relevant or not. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateEventSource(setupProc, checkProc, clientData) + Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out + * what to wait for. */ + Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting + * to see what happened. */ + ClientData clientData; /* One-word argument to pass to + * setupProc and checkProc. */ +{ + EventSource *sourcePtr; + + if (!initialized) { + InitNotifier(); + } + + sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); + sourcePtr->setupProc = setupProc; + sourcePtr->checkProc = checkProc; + sourcePtr->clientData = clientData; + sourcePtr->nextPtr = notifier.firstEventSourcePtr; + notifier.firstEventSourcePtr = sourcePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteEventSource -- + * + * This procedure is invoked to delete the source of events + * given by proc and clientData. + * + * Results: + * None. + * + * Side effects: + * The given event source is cancelled, so its procedure will + * never again be called. If no such source exists, nothing + * happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteEventSource(setupProc, checkProc, clientData) + Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out + * what to wait for. */ + Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting + * to see what happened. */ + ClientData clientData; /* One-word argument to pass to + * setupProc and checkProc. */ +{ + EventSource *sourcePtr, *prevPtr; + + for (sourcePtr = notifier.firstEventSourcePtr, prevPtr = NULL; + sourcePtr != NULL; + prevPtr = sourcePtr, sourcePtr = sourcePtr->nextPtr) { + if ((sourcePtr->setupProc != setupProc) + || (sourcePtr->checkProc != checkProc) + || (sourcePtr->clientData != clientData)) { + continue; + } + if (prevPtr == NULL) { + notifier.firstEventSourcePtr = sourcePtr->nextPtr; + } else { + prevPtr->nextPtr = sourcePtr->nextPtr; + } + ckfree((char *) sourcePtr); + return; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_QueueEvent -- + * + * Insert an event into the Tk event queue at one of three + * positions: the head, the tail, or before a floating marker. + * Events inserted before the marker will be processed in + * first-in-first-out order, but before any events inserted at + * the tail of the queue. Events inserted at the head of the + * queue will be processed in last-in-first-out order. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_QueueEvent(evPtr, position) + Tcl_Event* evPtr; /* Event to add to queue. The storage + * space must have been allocated the caller + * with malloc (ckalloc), and it becomes + * the property of the event queue. It + * will be freed after the event has been + * handled. */ + Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, + * TCL_QUEUE_MARK. */ +{ + if (!initialized) { + InitNotifier(); + } + + if (position == TCL_QUEUE_TAIL) { + /* + * Append the event on the end of the queue. + */ + + evPtr->nextPtr = NULL; + if (notifier.firstEventPtr == NULL) { + notifier.firstEventPtr = evPtr; + } else { + notifier.lastEventPtr->nextPtr = evPtr; + } + notifier.lastEventPtr = evPtr; + } else if (position == TCL_QUEUE_HEAD) { + /* + * Push the event on the head of the queue. + */ + + evPtr->nextPtr = notifier.firstEventPtr; + if (notifier.firstEventPtr == NULL) { + notifier.lastEventPtr = evPtr; + } + notifier.firstEventPtr = evPtr; + } else if (position == TCL_QUEUE_MARK) { + /* + * Insert the event after the current marker event and advance + * the marker to the new event. + */ + + if (notifier.markerEventPtr == NULL) { + evPtr->nextPtr = notifier.firstEventPtr; + notifier.firstEventPtr = evPtr; + } else { + evPtr->nextPtr = notifier.markerEventPtr->nextPtr; + notifier.markerEventPtr->nextPtr = evPtr; + } + notifier.markerEventPtr = evPtr; + if (evPtr->nextPtr == NULL) { + notifier.lastEventPtr = evPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteEvents -- + * + * Calls a procedure for each event in the queue and deletes those + * for which the procedure returns 1. Events for which the + * procedure returns 0 are left in the queue. + * + * Results: + * None. + * + * Side effects: + * Potentially removes one or more events from the event queue. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteEvents(proc, clientData) + Tcl_EventDeleteProc *proc; /* The procedure to call. */ + ClientData clientData; /* type-specific data. */ +{ + Tcl_Event *evPtr, *prevPtr, *hold; + + if (!initialized) { + InitNotifier(); + } + + for (prevPtr = (Tcl_Event *) NULL, evPtr = notifier.firstEventPtr; + evPtr != (Tcl_Event *) NULL; + ) { + if ((*proc) (evPtr, clientData) == 1) { + if (notifier.firstEventPtr == evPtr) { + notifier.firstEventPtr = evPtr->nextPtr; + if (evPtr->nextPtr == NULL) { + notifier.lastEventPtr = prevPtr; + } + if (notifier.markerEventPtr == evPtr) { + notifier.markerEventPtr = prevPtr; + } + } else { + prevPtr->nextPtr = evPtr->nextPtr; + } + hold = evPtr; + evPtr = evPtr->nextPtr; + ckfree((char *) hold); + } else { + prevPtr = evPtr; + evPtr = evPtr->nextPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ServiceEvent -- + * + * Process one event from the event queue, or invoke an + * asynchronous event handler. + * + * Results: + * The return value is 1 if the procedure actually found an event + * to process. If no processing occurred, then 0 is returned. + * + * Side effects: + * Invokes all of the event handlers for the highest priority + * event in the event queue. May collapse some events into a + * single event or discard stale events. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ServiceEvent(flags) + int flags; /* Indicates what events should be processed. + * May be any combination of TCL_WINDOW_EVENTS + * TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other + * flags defined elsewhere. Events not + * matching this will be skipped for processing + * later. */ +{ + Tcl_Event *evPtr, *prevPtr; + Tcl_EventProc *proc; + + if (!initialized) { + InitNotifier(); + } + + /* + * Asynchronous event handlers are considered to be the highest + * priority events, and so must be invoked before we process events + * on the event queue. + */ + + if (Tcl_AsyncReady()) { + (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); + return 1; + } + + /* + * No event flags is equivalent to TCL_ALL_EVENTS. + */ + + if ((flags & TCL_ALL_EVENTS) == 0) { + flags |= TCL_ALL_EVENTS; + } + + /* + * Loop through all the events in the queue until we find one + * that can actually be handled. + */ + + for (evPtr = notifier.firstEventPtr; evPtr != NULL; + evPtr = evPtr->nextPtr) { + /* + * Call the handler for the event. If it actually handles the + * event then free the storage for the event. There are two + * tricky things here, but stemming from the fact that the event + * code may be re-entered while servicing the event: + * + * 1. Set the "proc" field to NULL. This is a signal to ourselves + * that we shouldn't reexecute the handler if the event loop + * is re-entered. + * 2. When freeing the event, must search the queue again from the + * front to find it. This is because the event queue could + * change almost arbitrarily while handling the event, so we + * can't depend on pointers found now still being valid when + * the handler returns. + */ + + proc = evPtr->proc; + evPtr->proc = NULL; + if ((proc != NULL) && (*proc)(evPtr, flags)) { + if (notifier.firstEventPtr == evPtr) { + notifier.firstEventPtr = evPtr->nextPtr; + if (evPtr->nextPtr == NULL) { + notifier.lastEventPtr = NULL; + } + if (notifier.markerEventPtr == evPtr) { + notifier.markerEventPtr = NULL; + } + } else { + for (prevPtr = notifier.firstEventPtr; + prevPtr->nextPtr != evPtr; prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = evPtr->nextPtr; + if (evPtr->nextPtr == NULL) { + notifier.lastEventPtr = prevPtr; + } + if (notifier.markerEventPtr == evPtr) { + notifier.markerEventPtr = prevPtr; + } + } + ckfree((char *) evPtr); + return 1; + } else { + /* + * The event wasn't actually handled, so we have to restore + * the proc field to allow the event to be attempted again. + */ + + evPtr->proc = proc; + } + + /* + * The handler for this event asked to defer it. Just go on to + * the next event. + */ + + continue; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetServiceMode -- + * + * This routine returns the current service mode of the notifier. + * + * Results: + * Returns either TCL_SERVICE_ALL or TCL_SERVICE_NONE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetServiceMode() +{ + if (!initialized) { + InitNotifier(); + } + + return notifier.serviceMode; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetServiceMode -- + * + * This routine sets the current service mode of the notifier. + * + * Results: + * Returns the previous service mode. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetServiceMode(mode) + int mode; /* New service mode: TCL_SERVICE_ALL or + * TCL_SERVICE_NONE */ +{ + int oldMode; + + if (!initialized) { + InitNotifier(); + } + + oldMode = notifier.serviceMode; + notifier.serviceMode = mode; + return oldMode; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetMaxBlockTime -- + * + * This procedure is invoked by event sources to tell the notifier + * how long it may block the next time it blocks. The timePtr + * argument gives a maximum time; the actual time may be less if + * some other event source requested a smaller time. + * + * Results: + * None. + * + * Side effects: + * May reduce the length of the next sleep in the notifier. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetMaxBlockTime(timePtr) + Tcl_Time *timePtr; /* Specifies a maximum elapsed time for + * the next blocking operation in the + * event notifier. */ +{ + if (!initialized) { + InitNotifier(); + } + + if (!notifier.blockTimeSet || (timePtr->sec < notifier.blockTime.sec) + || ((timePtr->sec == notifier.blockTime.sec) + && (timePtr->usec < notifier.blockTime.usec))) { + notifier.blockTime = *timePtr; + notifier.blockTimeSet = 1; + } + + /* + * If we are called outside an event source traversal, set the + * timeout immediately. + */ + + if (!notifier.inTraversal) { + if (notifier.blockTimeSet) { + Tcl_SetTimer(¬ifier.blockTime); + } else { + Tcl_SetTimer(NULL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DoOneEvent -- + * + * Process a single event of some sort. If there's no work to + * do, wait for an event to occur, then process it. + * + * Results: + * The return value is 1 if the procedure actually found an event + * to process. If no processing occurred, then 0 is returned (this + * can happen if the TCL_DONT_WAIT flag is set or if there are no + * event handlers to wait for in the set specified by flags). + * + * Side effects: + * May delay execution of process while waiting for an event, + * unless TCL_DONT_WAIT is set in the flags argument. Event + * sources are invoked to check for and queue events. Event + * handlers may produce arbitrary side effects. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DoOneEvent(flags) + int flags; /* Miscellaneous flag values: may be any + * combination of TCL_DONT_WAIT, + * TCL_WINDOW_EVENTS, TCL_FILE_EVENTS, + * TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, or + * others defined by event sources. */ +{ + int result = 0, oldMode; + EventSource *sourcePtr; + Tcl_Time *timePtr; + + if (!initialized) { + InitNotifier(); + } + + /* + * The first thing we do is to service any asynchronous event + * handlers. + */ + + if (Tcl_AsyncReady()) { + (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); + return 1; + } + + /* + * No event flags is equivalent to TCL_ALL_EVENTS. + */ + + if ((flags & TCL_ALL_EVENTS) == 0) { + flags |= TCL_ALL_EVENTS; + } + + /* + * Set the service mode to none so notifier event routines won't + * try to service events recursively. + */ + + oldMode = notifier.serviceMode; + notifier.serviceMode = TCL_SERVICE_NONE; + + /* + * The core of this procedure is an infinite loop, even though + * we only service one event. The reason for this is that we + * may be processing events that don't do anything inside of Tcl. + */ + + while (1) { + + /* + * If idle events are the only things to service, skip the + * main part of the loop and go directly to handle idle + * events (i.e. don't wait even if TCL_DONT_WAIT isn't set). + */ + + if ((flags & TCL_ALL_EVENTS) == TCL_IDLE_EVENTS) { + flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; + goto idleEvents; + } + + /* + * Ask Tcl to service a queued event, if there are any. + */ + + if (Tcl_ServiceEvent(flags)) { + result = 1; + break; + } + + /* + * If TCL_DONT_WAIT is set, be sure to poll rather than + * blocking, otherwise reset the block time to infinity. + */ + + if (flags & TCL_DONT_WAIT) { + notifier.blockTime.sec = 0; + notifier.blockTime.usec = 0; + notifier.blockTimeSet = 1; + } else { + notifier.blockTimeSet = 0; + } + + /* + * Set up all the event sources for new events. This will + * cause the block time to be updated if necessary. + */ + + notifier.inTraversal = 1; + for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL; + sourcePtr = sourcePtr->nextPtr) { + if (sourcePtr->setupProc) { + (sourcePtr->setupProc)(sourcePtr->clientData, flags); + } + } + notifier.inTraversal = 0; + + if ((flags & TCL_DONT_WAIT) || notifier.blockTimeSet) { + timePtr = ¬ifier.blockTime; + } else { + timePtr = NULL; + } + + /* + * Wait for a new event or a timeout. If Tcl_WaitForEvent + * returns -1, we should abort Tcl_DoOneEvent. + */ + + result = Tcl_WaitForEvent(timePtr); + if (result < 0) { + result = 0; + break; + } + + /* + * Check all the event sources for new events. + */ + + for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL; + sourcePtr = sourcePtr->nextPtr) { + if (sourcePtr->checkProc) { + (sourcePtr->checkProc)(sourcePtr->clientData, flags); + } + } + + /* + * Check for events queued by the notifier or event sources. + */ + + if (Tcl_ServiceEvent(flags)) { + result = 1; + break; + } + + /* + * We've tried everything at this point, but nobody we know + * about had anything to do. Check for idle events. If none, + * either quit or go back to the top and try again. + */ + + idleEvents: + if (flags & TCL_IDLE_EVENTS) { + if (TclServiceIdle()) { + result = 1; + break; + } + } + if (flags & TCL_DONT_WAIT) { + break; + } + + /* + * If Tcl_WaitForEvent has returned 1, + * indicating that one system event has been dispatched + * (and thus that some Tcl code might have been indirectly executed), + * we break out of the loop. + * We do this to give VwaitCmd for instance a chance to check + * if that system event had the side effect of changing the + * variable (so the vwait can return and unwind properly). + * + * NB: We will process idle events if any first, because + * otherwise we might never do the idle events if the notifier + * always gets system events. + */ + + if (result) { + break; + } + + } + + notifier.serviceMode = oldMode; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ServiceAll -- + * + * This routine checks all of the event sources, processes + * events that are on the Tcl event queue, and then calls the + * any idle handlers. Platform specific notifier callbacks that + * generate events should call this routine before returning to + * the system in order to ensure that Tcl gets a chance to + * process the new events. + * + * Results: + * Returns 1 if an event or idle handler was invoked, else 0. + * + * Side effects: + * Anything that an event or idle handler may do. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ServiceAll() +{ + int result = 0; + EventSource *sourcePtr; + + if (!initialized) { + InitNotifier(); + } + + if (notifier.serviceMode == TCL_SERVICE_NONE) { + return result; + } + + /* + * We need to turn off event servicing like we to in Tcl_DoOneEvent, + * to avoid recursive calls. + */ + + notifier.serviceMode = TCL_SERVICE_NONE; + + /* + * Check async handlers first. + */ + + if (Tcl_AsyncReady()) { + (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); + } + + /* + * Make a single pass through all event sources, queued events, + * and idle handlers. Note that we wait to update the notifier + * timer until the end so we can avoid multiple changes. + */ + + notifier.inTraversal = 1; + notifier.blockTimeSet = 0; + + for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL; + sourcePtr = sourcePtr->nextPtr) { + if (sourcePtr->setupProc) { + (sourcePtr->setupProc)(sourcePtr->clientData, TCL_ALL_EVENTS); + } + } + for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL; + sourcePtr = sourcePtr->nextPtr) { + if (sourcePtr->checkProc) { + (sourcePtr->checkProc)(sourcePtr->clientData, TCL_ALL_EVENTS); + } + } + + while (Tcl_ServiceEvent(0)) { + result = 1; + } + if (TclServiceIdle()) { + result = 1; + } + + if (!notifier.blockTimeSet) { + Tcl_SetTimer(NULL); + } else { + Tcl_SetTimer(¬ifier.blockTime); + } + notifier.inTraversal = 0; + notifier.serviceMode = TCL_SERVICE_ALL; + return result; +} diff --git a/tcl/generic/tclObj.c b/tcl/generic/tclObj.c new file mode 100644 index 00000000000..8f0812c68dc --- /dev/null +++ b/tcl/generic/tclObj.c @@ -0,0 +1,2142 @@ +/* + * tclObj.c -- + * + * This file contains Tcl object-related procedures that are used by + * many Tcl commands. + * + * Copyright (c) 1995-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Table of all object types. + */ + +static Tcl_HashTable typeTable; +static int typeTableInitialized = 0; /* 0 means not yet initialized. */ + +/* + * Head of the list of free Tcl_Objs we maintain. + */ + +Tcl_Obj *tclFreeObjList = NULL; + +/* + * Pointer to a heap-allocated string of length zero that the Tcl core uses + * as the value of an empty string representation for an object. This value + * is shared by all new objects allocated by Tcl_NewObj. + */ + +char *tclEmptyStringRep = NULL; + +/* + * Count of the number of Tcl objects every allocated (by Tcl_NewObj) and + * freed (by TclFreeObj). + */ + +#ifdef TCL_COMPILE_STATS +long tclObjsAlloced = 0; +long tclObjsFreed = 0; +#endif /* TCL_COMPILE_STATS */ + +/* + * Prototypes for procedures defined later in this file: + */ + +static void DupBooleanInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void DupDoubleInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void DupIntInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void FinalizeTypeTable _ANSI_ARGS_((void)); +static void FinalizeFreeObjList _ANSI_ARGS_((void)); +static void InitTypeTable _ANSI_ARGS_((void)); +static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); + +/* + * The structures below defines the Tcl object types defined in this file by + * means of procedures that can be invoked by generic object code. See also + * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager + * implementations. + */ + +Tcl_ObjType tclBooleanType = { + "boolean", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + DupBooleanInternalRep, /* dupIntRepProc */ + UpdateStringOfBoolean, /* updateStringProc */ + SetBooleanFromAny /* setFromAnyProc */ +}; + +Tcl_ObjType tclDoubleType = { + "double", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + DupDoubleInternalRep, /* dupIntRepProc */ + UpdateStringOfDouble, /* updateStringProc */ + SetDoubleFromAny /* setFromAnyProc */ +}; + +Tcl_ObjType tclIntType = { + "int", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + DupIntInternalRep, /* dupIntRepProc */ + UpdateStringOfInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ +}; + +/* + *-------------------------------------------------------------- + * + * InitTypeTable -- + * + * This procedure is invoked to perform once-only initialization of + * the type table. It also registers the object types defined in + * this file. + * + * Results: + * None. + * + * Side effects: + * Initializes the table of defined object types "typeTable" with + * builtin object types defined in this file. It also initializes the + * value of tclEmptyStringRep, which points to the heap-allocated + * string of length zero used as the string representation for + * newly-created objects. + * + *-------------------------------------------------------------- + */ + +static void +InitTypeTable() +{ + typeTableInitialized = 1; + + Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); + Tcl_RegisterObjType(&tclBooleanType); + Tcl_RegisterObjType(&tclDoubleType); + Tcl_RegisterObjType(&tclIntType); + Tcl_RegisterObjType(&tclStringType); + Tcl_RegisterObjType(&tclListType); + Tcl_RegisterObjType(&tclByteCodeType); + Tcl_RegisterObjType(&tclProcBodyType); + + tclEmptyStringRep = (char *) ckalloc((unsigned) 1); + tclEmptyStringRep[0] = '\0'; +} + +/* + *---------------------------------------------------------------------- + * + * FinalizeTypeTable -- + * + * This procedure is called by Tcl_Finalize after all exit handlers + * have been run to free up storage associated with the table of Tcl + * object types. + * + * Results: + * None. + * + * Side effects: + * Deletes all entries in the hash table of object types, "typeTable". + * Then sets "typeTableInitialized" to 0 so that the Tcl type system + * will be properly reinitialized if Tcl is restarted. Also deallocates + * the storage for tclEmptyStringRep. + * + *---------------------------------------------------------------------- + */ + +static void +FinalizeTypeTable() +{ + if (typeTableInitialized) { + Tcl_DeleteHashTable(&typeTable); + ckfree(tclEmptyStringRep); + typeTableInitialized = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * FinalizeFreeObjList -- + * + * Resets the free object list so it can later be reinitialized. + * + * Results: + * None. + * + * Side effects: + * Resets the value of tclFreeObjList. + * + *---------------------------------------------------------------------- + */ + +static void +FinalizeFreeObjList() +{ + tclFreeObjList = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeCompExecEnv -- + * + * Clean up the compiler execution environment so it can later be + * properly reinitialized. + * + * Results: + * None. + * + * Side effects: + * Cleans up the execution environment + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeCompExecEnv() +{ + FinalizeTypeTable(); + FinalizeFreeObjList(); + TclFinalizeExecEnv(); +} + +/* + *-------------------------------------------------------------- + * + * Tcl_RegisterObjType -- + * + * This procedure is called to register a new Tcl object type + * in the table of all object types supported by Tcl. + * + * Results: + * None. + * + * Side effects: + * The type is registered in the Tcl type table. If there was already + * a type with the same name as in typePtr, it is replaced with the + * new type. + * + *-------------------------------------------------------------- + */ + +void +Tcl_RegisterObjType(typePtr) + Tcl_ObjType *typePtr; /* Information about object type; + * storage must be statically + * allocated (must live forever). */ +{ + register Tcl_HashEntry *hPtr; + int new; + + if (!typeTableInitialized) { + InitTypeTable(); + } + + /* + * If there's already an object type with the given name, remove it. + */ + + hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name); + if (hPtr != (Tcl_HashEntry *) NULL) { + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Now insert the new object type. + */ + + hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new); + if (new) { + Tcl_SetHashValue(hPtr, typePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendAllObjTypes -- + * + * This procedure appends onto the argument object the name of each + * object type as a list element. This includes the builtin object + * types (e.g. int, list) as well as those added using + * Tcl_CreateObjType. These names can be used, for example, with + * Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType + * structures. + * + * Results: + * The return value is normally TCL_OK; in this case the object + * referenced by objPtr has each type name appended to it. If an + * error occurs, TCL_ERROR is returned and the interpreter's result + * holds an error message. + * + * Side effects: + * If necessary, the object referenced by objPtr is converted into + * a list object. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppendAllObjTypes(interp, objPtr) + Tcl_Interp *interp; /* Interpreter used for error reporting. */ + Tcl_Obj *objPtr; /* Points to the Tcl object onto which the + * name of each registered type is appended + * as a list element. */ +{ + register Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_ObjType *typePtr; + int result; + + if (!typeTableInitialized) { + InitTypeTable(); + } + + /* + * This code assumes that types names do not contain embedded NULLs. + */ + + for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); + result = Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj(typePtr->name, -1)); + if (result == TCL_ERROR) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetObjType -- + * + * This procedure looks up an object type by name. + * + * Results: + * If an object type with name matching "typeName" is found, a pointer + * to its Tcl_ObjType structure is returned; otherwise, NULL is + * returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_ObjType * +Tcl_GetObjType(typeName) + char *typeName; /* Name of Tcl object type to look up. */ +{ + register Tcl_HashEntry *hPtr; + Tcl_ObjType *typePtr; + + if (!typeTableInitialized) { + InitTypeTable(); + } + + hPtr = Tcl_FindHashEntry(&typeTable, typeName); + if (hPtr != (Tcl_HashEntry *) NULL) { + typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); + return typePtr; + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConvertToType -- + * + * Convert the Tcl object "objPtr" to have type "typePtr" if possible. + * + * Results: + * The return value is TCL_OK on success and TCL_ERROR on failure. If + * TCL_ERROR is returned, then the interpreter's result contains an + * error message unless "interp" is NULL. Passing a NULL "interp" + * allows this procedure to be used as a test whether the conversion + * could be done (and in fact was done). + * + * Side effects: + * Any internal representation for the old type is freed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ConvertToType(interp, objPtr, typePtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ + Tcl_ObjType *typePtr; /* The target type. */ +{ + if (objPtr->typePtr == typePtr) { + return TCL_OK; + } + + /* + * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal + * form as appropriate for the target type. This frees the old internal + * representation. + */ + + return typePtr->setFromAnyProc(interp, objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewObj -- + * + * This procedure is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote + * the empty string. These objects have a NULL object type and NULL + * string representation byte pointer. Type managers call this routine + * to allocate new objects that they further initialize. + * + * When TCL_MEM_DEBUG is defined, this procedure just returns the + * result of calling the debugging version Tcl_DbNewObj. + * + * Results: + * The result is a newly allocated object that represents the empty + * string. The new object's typePtr is set NULL and its ref count + * is set to 0. + * + * Side effects: + * If compiling with TCL_COMPILE_STATS, this procedure increments + * the global count of allocated objects (tclObjsAlloced). + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewObj + +Tcl_Obj * +Tcl_NewObj() +{ + return Tcl_DbNewObj("unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewObj() +{ + register Tcl_Obj *objPtr; + + /* + * Allocate the object using the list of free Tcl_Objs we maintain. + */ + + if (tclFreeObjList == NULL) { + TclAllocateFreeObjects(); + } + objPtr = tclFreeObjList; + tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr; + + objPtr->refCount = 0; + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; + objPtr->typePtr = NULL; +#ifdef TCL_COMPILE_STATS + tclObjsAlloced++; +#endif /* TCL_COMPILE_STATS */ + return objPtr; +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewObj -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the + * empty string. It is the same as the Tcl_NewObj procedure above + * except that it calls Tcl_DbCkalloc directly with the file name and + * line number from its caller. This simplifies debugging since then + * the checkmem command will report the correct file name and line + * number when reporting objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * result of calling Tcl_NewObj. + * + * Results: + * The result is a newly allocated that represents the empty string. + * The new object's typePtr is set NULL and its ref count is set to 0. + * + * Side effects: + * If compiling with TCL_COMPILE_STATS, this procedure increments + * the global count of allocated objects (tclObjsAlloced). + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewObj(file, line) + register char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + register int line; /* Line number in the source file; used + * for debugging. */ +{ + register Tcl_Obj *objPtr; + + /* + * If debugging Tcl's memory usage, allocate the object using ckalloc. + * Otherwise, allocate it using the list of free Tcl_Objs we maintain. + */ + + objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line); + objPtr->refCount = 0; + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; + objPtr->typePtr = NULL; +#ifdef TCL_COMPILE_STATS + tclObjsAlloced++; +#endif /* TCL_COMPILE_STATS */ + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewObj(file, line) + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return Tcl_NewObj(); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclAllocateFreeObjects -- + * + * Procedure to allocate a number of free Tcl_Objs. This is done using + * a single ckalloc to reduce the overhead for Tcl_Obj allocation. + * + * Results: + * None. + * + * Side effects: + * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the + * first of a number of free Tcl_Obj's linked together by their + * internalRep.otherValuePtrs. + * + *---------------------------------------------------------------------- + */ + +#define OBJS_TO_ALLOC_EACH_TIME 100 + +void +TclAllocateFreeObjects() +{ + Tcl_Obj tmp[2]; + size_t objSizePlusPadding = /* NB: this assumes byte addressing. */ + ((int)(&(tmp[1])) - (int)(&(tmp[0]))); + size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding); + char *basePtr; + register Tcl_Obj *prevPtr, *objPtr; + register int i; + + basePtr = (char *) ckalloc(bytesToAlloc); + memset(basePtr, 0, bytesToAlloc); + + prevPtr = NULL; + objPtr = (Tcl_Obj *) basePtr; + for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { + objPtr->internalRep.otherValuePtr = (VOID *) prevPtr; + prevPtr = objPtr; + objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding); + } + tclFreeObjList = prevPtr; +} +#undef OBJS_TO_ALLOC_EACH_TIME + +/* + *---------------------------------------------------------------------- + * + * TclFreeObj -- + * + * This procedure frees the memory associated with the argument + * object. It is called by the tcl.h macro Tcl_DecrRefCount when an + * object's ref count is zero. It is only "public" since it must + * be callable by that macro wherever the macro is used. It should not + * be directly called by clients. + * + * Results: + * None. + * + * Side effects: + * Deallocates the storage for the object's Tcl_Obj structure + * after deallocating the string representation and calling the + * type-specific Tcl_FreeInternalRepProc to deallocate the object's + * internal representation. If compiling with TCL_COMPILE_STATS, + * this procedure increments the global count of freed objects + * (tclObjsFreed). + * + *---------------------------------------------------------------------- + */ + +void +TclFreeObj(objPtr) + register Tcl_Obj *objPtr; /* The object to be freed. */ +{ + register Tcl_ObjType *typePtr = objPtr->typePtr; + +#ifdef TCL_MEM_DEBUG + if ((objPtr)->refCount < -1) { + panic("Reference count for %lx was negative", objPtr); + } +#endif /* TCL_MEM_DEBUG */ + + Tcl_InvalidateStringRep(objPtr); + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + typePtr->freeIntRepProc(objPtr); + } + + /* + * If debugging Tcl's memory usage, deallocate the object using ckfree. + * Otherwise, deallocate it by adding it onto the list of free + * Tcl_Objs we maintain. + */ + +#ifdef TCL_MEM_DEBUG + ckfree((char *) objPtr); +#else + objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList; + tclFreeObjList = objPtr; +#endif /* TCL_MEM_DEBUG */ + +#ifdef TCL_COMPILE_STATS + tclObjsFreed++; +#endif /* TCL_COMPILE_STATS */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DuplicateObj -- + * + * Create and return a new object that is a duplicate of the argument + * object. + * + * Results: + * The return value is a pointer to a newly created Tcl_Obj. This + * object has reference count 0 and the same type, if any, as the + * source object objPtr. Also: + * 1) If the source object has a valid string rep, we copy it; + * otherwise, the duplicate's string rep is set NULL to mark + * it invalid. + * 2) If the source object has an internal representation (i.e. its + * typePtr is non-NULL), the new object's internal rep is set to + * a copy; otherwise the new internal rep is marked invalid. + * + * Side effects: + * What constitutes "copying" the internal representation depends on + * the type. For example, if the argument object is a list, + * the element objects it points to will not actually be copied but + * will be shared with the duplicate list. That is, the ref counts of + * the element objects will be incremented. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_DuplicateObj(objPtr) + register Tcl_Obj *objPtr; /* The object to duplicate. */ +{ + register Tcl_ObjType *typePtr = objPtr->typePtr; + register Tcl_Obj *dupPtr; + + TclNewObj(dupPtr); + + if (objPtr->bytes == NULL) { + dupPtr->bytes = NULL; + } else if (objPtr->bytes != tclEmptyStringRep) { + int len = objPtr->length; + + dupPtr->bytes = (char *) ckalloc((unsigned) len+1); + if (len > 0) { + memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes, + (unsigned) len); + } + dupPtr->bytes[len] = '\0'; + dupPtr->length = len; + } + + if (typePtr != NULL) { + typePtr->dupIntRepProc(objPtr, dupPtr); + } + return dupPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetStringFromObj -- + * + * Returns the string representation's byte array pointer and length + * for an object. + * + * Results: + * Returns a pointer to the string representation of objPtr. If + * lengthPtr isn't NULL, the length of the string representation is + * stored at *lengthPtr. The byte array referenced by the returned + * pointer must not be modified by the caller. Furthermore, the + * caller must copy the bytes if they need to retain them since the + * object's string rep can change as a result of other operations. + * + * Side effects: + * May call the object's updateStringProc to update the string + * representation from the internal representation. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetStringFromObj(objPtr, lengthPtr) + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer + * should be returned. */ + register int *lengthPtr; /* If non-NULL, the location where the + * string rep's byte array length should be + * stored. If NULL, no length is stored. */ +{ + if (objPtr->bytes != NULL) { + if (lengthPtr != NULL) { + *lengthPtr = objPtr->length; + } + return objPtr->bytes; + } + + objPtr->typePtr->updateStringProc(objPtr); + if (lengthPtr != NULL) { + *lengthPtr = objPtr->length; + } + return objPtr->bytes; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InvalidateStringRep -- + * + * This procedure is called to invalidate an object's string + * representation. + * + * Results: + * None. + * + * Side effects: + * Deallocates the storage for any old string representation, then + * sets the string representation NULL to mark it invalid. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_InvalidateStringRep(objPtr) + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer + * should be freed. */ +{ + if (objPtr->bytes != NULL) { + if (objPtr->bytes != tclEmptyStringRep) { + ckfree((char *) objPtr->bytes); + } + objPtr->bytes = NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewBooleanObj -- + * + * This procedure is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new boolean object and + * initializes it from the argument boolean value. A nonzero + * "boolValue" is coerced to 1. + * + * When TCL_MEM_DEBUG is defined, this procedure just returns the + * result of calling the debugging version Tcl_DbNewBooleanObj. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewBooleanObj + +Tcl_Obj * +Tcl_NewBooleanObj(boolValue) + register int boolValue; /* Boolean used to initialize new object. */ +{ + return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewBooleanObj(boolValue) + register int boolValue; /* Boolean used to initialize new object. */ +{ + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->typePtr = &tclBooleanType; + return objPtr; +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewBooleanObj -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the + * same as the Tcl_NewBooleanObj procedure above except that it calls + * Tcl_DbCkalloc directly with the file name and line number from its + * caller. This simplifies debugging since then the checkmem command + * will report the correct file name and line number when reporting + * objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * result of calling Tcl_NewBooleanObj. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewBooleanObj(boolValue, file, line) + register int boolValue; /* Boolean used to initialize new object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->typePtr = &tclBooleanType; + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewBooleanObj(boolValue, file, line) + register int boolValue; /* Boolean used to initialize new object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return Tcl_NewBooleanObj(boolValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetBooleanObj -- + * + * Modify an object to be a boolean object and to have the specified + * boolean value. A nonzero "boolValue" is coerced to 1. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old + * internal rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetBooleanObj(objPtr, boolValue) + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ + register int boolValue; /* Boolean used to set object's value. */ +{ + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetBooleanObj called with shared object"); + } + + Tcl_InvalidateStringRep(objPtr); + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->typePtr = &tclBooleanType; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetBooleanFromObj -- + * + * Attempt to return a boolean from the Tcl object "objPtr". If the + * object is not already a boolean, an attempt will be made to convert + * it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already a boolean, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object from which to get boolean. */ + register int *boolPtr; /* Place to store resulting boolean. */ +{ + register int result; + + result = SetBooleanFromAny(interp, objPtr); + if (result == TCL_OK) { + *boolPtr = (int) objPtr->internalRep.longValue; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DupBooleanInternalRep -- + * + * Initialize the internal representation of a boolean Tcl_Obj to a + * copy of the internal representation of an existing boolean object. + * + * Results: + * None. + * + * Side effects: + * "copyPtr"s internal rep is set to the boolean (an integer) + * corresponding to "srcPtr"s internal rep. + * + *---------------------------------------------------------------------- + */ + +static void +DupBooleanInternalRep(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + copyPtr->internalRep.longValue = srcPtr->internalRep.longValue; + copyPtr->typePtr = &tclBooleanType; +} + +/* + *---------------------------------------------------------------------- + * + * SetBooleanFromAny -- + * + * Attempt to generate a boolean internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard Tcl result. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * If no error occurs, an integer 1 or 0 is stored as "objPtr"s + * internal representation and the type of "objPtr" is set to boolean. + * + *---------------------------------------------------------------------- + */ + +static int +SetBooleanFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *end; + register char c; + char lowerCase[10]; + int newBool, length; + register int i; + double dbl; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = TclGetStringFromObj(objPtr, &length); + + /* + * Copy the string converting its characters to lower case. + */ + + for (i = 0; (i < 9) && (i < length); i++) { + c = string[i]; + if (isupper(UCHAR(c))) { + c = (char) tolower(UCHAR(c)); + } + lowerCase[i] = c; + } + lowerCase[i] = 0; + + /* + * Parse the string as a boolean. We use an implementation here that + * doesn't report errors in interp if interp is NULL. + */ + + c = lowerCase[0]; + if ((c == '0') && (lowerCase[1] == '\0')) { + newBool = 0; + } else if ((c == '1') && (lowerCase[1] == '\0')) { + newBool = 1; + } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) { + newBool = 1; + } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) { + newBool = 0; + } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) { + newBool = 1; + } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) { + newBool = 0; + } else if ((c == 'o') && (length >= 2)) { + if (strncmp(lowerCase, "on", (size_t) length) == 0) { + newBool = 1; + } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { + newBool = 0; + } else { + goto badBoolean; + } + } else { + /* + * Still might be a string containing the characters representing an + * int or double that wasn't handled above. This would be a string + * like "27" or "1.0" that is non-zero and not "1". Such a string + * whould result in the boolean value true. We try converting to + * double. If that succeeds and the resulting double is non-zero, we + * have a "true". Note that numbers can't have embedded NULLs. + */ + + dbl = strtod(string, &end); + if (end == string) { + goto badBoolean; + } + + /* + * Make sure the string has no garbage after the end of the double. + */ + + while ((end < (string+length)) && isspace(UCHAR(*end))) { + end++; + } + if (end != (string+length)) { + goto badBoolean; + } + newBool = (dbl != 0.0); + } + + /* + * Free the old internalRep before setting the new one. We do this as + * late as possible to allow the conversion code, in particular + * Tcl_GetStringFromObj, to use that old internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = newBool; + objPtr->typePtr = &tclBooleanType; + return TCL_OK; + + badBoolean: + if (interp != NULL) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to a boolean. + */ + + char buf[100]; + sprintf(buf, "expected boolean value but got \"%.50s\"", string); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfBoolean -- + * + * Update the string representation for a boolean object. + * Note: This procedure does not free an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the boolean-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfBoolean(objPtr) + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +{ + char *s = ckalloc((unsigned) 2); + + s[0] = (char) (objPtr->internalRep.longValue? '1' : '0'); + s[1] = '\0'; + objPtr->bytes = s; + objPtr->length = 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewDoubleObj -- + * + * This procedure is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new double object and + * initializes it from the argument double value. + * + * When TCL_MEM_DEBUG is defined, this procedure just returns the + * result of calling the debugging version Tcl_DbNewDoubleObj. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewDoubleObj + +Tcl_Obj * +Tcl_NewDoubleObj(dblValue) + register double dblValue; /* Double used to initialize the object. */ +{ + return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewDoubleObj(dblValue) + register double dblValue; /* Double used to initialize the object. */ +{ + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.doubleValue = dblValue; + objPtr->typePtr = &tclDoubleType; + return objPtr; +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewDoubleObj -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new double objects. It is the + * same as the Tcl_NewDoubleObj procedure above except that it calls + * Tcl_DbCkalloc directly with the file name and line number from its + * caller. This simplifies debugging since then the checkmem command + * will report the correct file name and line number when reporting + * objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * result of calling Tcl_NewDoubleObj. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewDoubleObj(dblValue, file, line) + register double dblValue; /* Double used to initialize the object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.doubleValue = dblValue; + objPtr->typePtr = &tclDoubleType; + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewDoubleObj(dblValue, file, line) + register double dblValue; /* Double used to initialize the object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return Tcl_NewDoubleObj(dblValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetDoubleObj -- + * + * Modify an object to be a double object and to have the specified + * double value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old + * internal rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetDoubleObj(objPtr, dblValue) + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ + register double dblValue; /* Double used to set the object's value. */ +{ + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetDoubleObj called with shared object"); + } + + Tcl_InvalidateStringRep(objPtr); + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.doubleValue = dblValue; + objPtr->typePtr = &tclDoubleType; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetDoubleFromObj -- + * + * Attempt to return a double from the Tcl object "objPtr". If the + * object is not already a double, an attempt will be made to convert + * it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already a double, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetDoubleFromObj(interp, objPtr, dblPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object from which to get a double. */ + register double *dblPtr; /* Place to store resulting double. */ +{ + register int result; + + if (objPtr->typePtr == &tclDoubleType) { + *dblPtr = objPtr->internalRep.doubleValue; + return TCL_OK; + } + + result = SetDoubleFromAny(interp, objPtr); + if (result == TCL_OK) { + *dblPtr = objPtr->internalRep.doubleValue; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DupDoubleInternalRep -- + * + * Initialize the internal representation of a double Tcl_Obj to a + * copy of the internal representation of an existing double object. + * + * Results: + * None. + * + * Side effects: + * "copyPtr"s internal rep is set to the double precision floating + * point number corresponding to "srcPtr"s internal rep. + * + *---------------------------------------------------------------------- + */ + +static void +DupDoubleInternalRep(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + copyPtr->internalRep.doubleValue = srcPtr->internalRep.doubleValue; + copyPtr->typePtr = &tclDoubleType; +} + +/* + *---------------------------------------------------------------------- + * + * SetDoubleFromAny -- + * + * Attempt to generate an double-precision floating point internal form + * for the Tcl object "objPtr". + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If no error occurs, a double is stored as "objPtr"s internal + * representation. + * + *---------------------------------------------------------------------- + */ + +static int +SetDoubleFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *end; + double newDouble; + int length; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = TclGetStringFromObj(objPtr, &length); + + /* + * Now parse "objPtr"s string as an double. Numbers can't have embedded + * NULLs. We use an implementation here that doesn't report errors in + * interp if interp is NULL. + */ + + errno = 0; + newDouble = strtod(string, &end); + if (end == string) { + badDouble: + if (interp != NULL) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to an int. + */ + + char buf[100]; + sprintf(buf, "expected floating-point number but got \"%.50s\"", + string); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + } + return TCL_ERROR; + } + if (errno != 0) { + if (interp != NULL) { + TclExprFloatError(interp, newDouble); + } + return TCL_ERROR; + } + + /* + * Make sure that the string has no garbage after the end of the double. + */ + + while ((end < (string+length)) && isspace(UCHAR(*end))) { + end++; + } + if (end != (string+length)) { + goto badDouble; + } + + /* + * The conversion to double succeeded. Free the old internalRep before + * setting the new one. We do this as late as possible to allow the + * conversion code, in particular Tcl_GetStringFromObj, to use that old + * internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.doubleValue = newDouble; + objPtr->typePtr = &tclDoubleType; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfDouble -- + * + * Update the string representation for a double-precision floating + * point object. This must obey the current tcl_precision value for + * double-to-string conversions. Note: This procedure does not free an + * existing old string rep so storage will be lost if this has not + * already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the double-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfDouble(objPtr) + register Tcl_Obj *objPtr; /* Double obj with string rep to update. */ +{ + char buffer[TCL_DOUBLE_SPACE]; + register int len; + + Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue, + buffer); + len = strlen(buffer); + + objPtr->bytes = (char *) ckalloc((unsigned) len + 1); + strcpy(objPtr->bytes, buffer); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewIntObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewIntObj to create a new integer object end up calling the + * debugging procedure Tcl_DbNewLongObj instead. + * + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, + * calls to Tcl_NewIntObj result in a call to one of the two + * Tcl_NewIntObj implementations below. We provide two implementations + * so that the Tcl core can be compiled to do memory debugging of the + * core even if a client does not request it for itself. + * + * Integer and long integer objects share the same "integer" type + * implementation. We store all integers as longs and Tcl_GetIntFromObj + * checks whether the current value of the long can be represented by + * an int. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewIntObj + +Tcl_Obj * +Tcl_NewIntObj(intValue) + register int intValue; /* Int used to initialize the new object. */ +{ + return Tcl_DbNewLongObj((long)intValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewIntObj(intValue) + register int intValue; /* Int used to initialize the new object. */ +{ + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = (long)intValue; + objPtr->typePtr = &tclIntType; + return objPtr; +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetIntObj -- + * + * Modify an object to be an integer and to have the specified integer + * value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old + * internal rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetIntObj(objPtr, intValue) + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ + register int intValue; /* Integer used to set object's value. */ +{ + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetIntObj called with shared object"); + } + + Tcl_InvalidateStringRep(objPtr); + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = (long) intValue; + objPtr->typePtr = &tclIntType; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetIntFromObj -- + * + * Attempt to return an int from the Tcl object "objPtr". If the object + * is not already an int, an attempt will be made to convert it to one. + * + * Integer and long integer objects share the same "integer" type + * implementation. We store all integers as longs and Tcl_GetIntFromObj + * checks whether the current value of the long can be represented by + * an int. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion or if the long integer held by the object + * can not be represented by an int, an error message is left in + * the interpreter's result unless "interp" is NULL. + * + * Side effects: + * If the object is not already an int, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetIntFromObj(interp, objPtr, intPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object from which to get a int. */ + register int *intPtr; /* Place to store resulting int. */ +{ + register long l; + int result; + + if (objPtr->typePtr != &tclIntType) { + result = SetIntFromAny(interp, objPtr); + if (result != TCL_OK) { + return result; + } + } + l = objPtr->internalRep.longValue; + if (((long)((int)l)) == l) { + *intPtr = (int)objPtr->internalRep.longValue; + return TCL_OK; + } + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent as non-long integer", -1); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DupIntInternalRep -- + * + * Initialize the internal representation of an int Tcl_Obj to a + * copy of the internal representation of an existing int object. + * + * Results: + * None. + * + * Side effects: + * "copyPtr"s internal rep is set to the integer corresponding to + * "srcPtr"s internal rep. + * + *---------------------------------------------------------------------- + */ + +static void +DupIntInternalRep(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + copyPtr->internalRep.longValue = srcPtr->internalRep.longValue; + copyPtr->typePtr = &tclIntType; +} + +/* + *---------------------------------------------------------------------- + * + * SetIntFromAny -- + * + * Attempt to generate an integer internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard object Tcl result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If no error occurs, an int is stored as "objPtr"s internal + * representation. + * + *---------------------------------------------------------------------- + */ + +static int +SetIntFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *end; + int length; + register char *p; + long newLong; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = TclGetStringFromObj(objPtr, &length); + + /* + * Now parse "objPtr"s string as an int. We use an implementation here + * that doesn't report errors in interp if interp is NULL. Note: use + * strtoul instead of strtol for integer conversions to allow full-size + * unsigned numbers, but don't depend on strtoul to handle sign + * characters; it won't in some implementations. + */ + + errno = 0; + for (p = string; isspace(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + if (*p == '-') { + p++; + newLong = -((long)strtoul(p, &end, 0)); + } else if (*p == '+') { + p++; + newLong = strtoul(p, &end, 0); + } else { + newLong = strtoul(p, &end, 0); + } + if (end == p) { + badInteger: + if (interp != NULL) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to an int. + */ + + char buf[100]; + sprintf(buf, "expected integer but got \"%.50s\"", string); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + } + return TCL_ERROR; + } + if (errno == ERANGE) { + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); + } + return TCL_ERROR; + } + + /* + * Make sure that the string has no garbage after the end of the int. + */ + + while ((end < (string+length)) && isspace(UCHAR(*end))) { + end++; + } + if (end != (string+length)) { + goto badInteger; + } + + /* + * The conversion to int succeeded. Free the old internalRep before + * setting the new one. We do this as late as possible to allow the + * conversion code, in particular Tcl_GetStringFromObj, to use that old + * internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = newLong; + objPtr->typePtr = &tclIntType; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfInt -- + * + * Update the string representation for an integer object. + * Note: This procedure does not free an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the int-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfInt(objPtr) + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +{ + char buffer[TCL_DOUBLE_SPACE]; + register int len; + + len = TclFormatInt(buffer, objPtr->internalRep.longValue); + + objPtr->bytes = ckalloc((unsigned) len + 1); + strcpy(objPtr->bytes, buffer); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewLongObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewLongObj to create a new long integer object end up calling + * the debugging procedure Tcl_DbNewLongObj instead. + * + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, + * calls to Tcl_NewLongObj result in a call to one of the two + * Tcl_NewLongObj implementations below. We provide two implementations + * so that the Tcl core can be compiled to do memory debugging of the + * core even if a client does not request it for itself. + * + * Integer and long integer objects share the same "integer" type + * implementation. We store all integers as longs and Tcl_GetIntFromObj + * checks whether the current value of the long can be represented by + * an int. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewLongObj + +Tcl_Obj * +Tcl_NewLongObj(longValue) + register long longValue; /* Long integer used to initialize the + * new object. */ +{ + return Tcl_DbNewLongObj(longValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewLongObj(longValue) + register long longValue; /* Long integer used to initialize the + * new object. */ +{ + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = longValue; + objPtr->typePtr = &tclIntType; + return objPtr; +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewLongObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or + * long integer objects end up calling the debugging procedure + * Tcl_DbNewLongObj instead. We provide two implementations of + * Tcl_DbNewLongObj so that whether the Tcl core is compiled to do + * memory debugging of the core is independent of whether a client + * requests debugging for itself. + * + * When the core is compiled with TCL_MEM_DEBUG defined, + * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and + * line number from its caller. This simplifies debugging since then + * the checkmem command will report the caller's file name and line + * number when reporting objects that haven't been freed. + * + * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, + * this procedure just returns the result of calling Tcl_NewLongObj. + * + * Results: + * The newly created long integer object is returned. This object + * will have an invalid string representation. The returned object has + * ref count 0. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewLongObj(longValue, file, line) + register long longValue; /* Long integer used to initialize the + * new object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = longValue; + objPtr->typePtr = &tclIntType; + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewLongObj(longValue, file, line) + register long longValue; /* Long integer used to initialize the + * new object. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return Tcl_NewLongObj(longValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetLongObj -- + * + * Modify an object to be an integer object and to have the specified + * long integer value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old + * internal rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetLongObj(objPtr, longValue) + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ + register long longValue; /* Long integer used to initialize the + * object's value. */ +{ + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetLongObj called with shared object"); + } + + Tcl_InvalidateStringRep(objPtr); + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = longValue; + objPtr->typePtr = &tclIntType; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetLongFromObj -- + * + * Attempt to return an long integer from the Tcl object "objPtr". If + * the object is not already an int object, an attempt will be made to + * convert it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already an int object, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetLongFromObj(interp, objPtr, longPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object from which to get a long. */ + register long *longPtr; /* Place to store resulting long. */ +{ + register int result; + + if (objPtr->typePtr == &tclIntType) { + *longPtr = objPtr->internalRep.longValue; + return TCL_OK; + } + result = SetIntFromAny(interp, objPtr); + if (result == TCL_OK) { + *longPtr = objPtr->internalRep.longValue; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbIncrRefCount -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. This checks to see whether or not + * the memory has been freed before incrementing the ref count. + * + * When TCL_MEM_DEBUG is not defined, this procedure just increments + * the reference count of the object. + * + * Results: + * None. + * + * Side effects: + * The object's ref count is incremented. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DbIncrRefCount(objPtr, file, line) + register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ +#ifdef TCL_MEM_DEBUG + if (objPtr->refCount == 0x61616161) { + fprintf(stderr, "file = %s, line = %d\n", file, line); + fflush(stderr); + panic("Trying to increment refCount of previously disposed object."); + } +#endif + ++(objPtr)->refCount; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbDecrRefCount -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. This checks to see whether or not + * the memory has been freed before incrementing the ref count. + * + * When TCL_MEM_DEBUG is not defined, this procedure just increments + * the reference count of the object. + * + * Results: + * None. + * + * Side effects: + * The object's ref count is incremented. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DbDecrRefCount(objPtr, file, line) + register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ +#ifdef TCL_MEM_DEBUG + if (objPtr->refCount == 0x61616161) { + fprintf(stderr, "file = %s, line = %d\n", file, line); + fflush(stderr); + panic("Trying to decrement refCount of previously disposed object."); + } +#endif + if (--(objPtr)->refCount <= 0) { + TclFreeObj(objPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbIsShared -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. This checks to see whether or not + * the memory has been freed before incrementing the ref count. + * + * When TCL_MEM_DEBUG is not defined, this procedure just decrements + * the reference count of the object and throws it away if the count + * is 0 or less. + * + * Results: + * None. + * + * Side effects: + * The object's ref count is incremented. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DbIsShared(objPtr, file, line) + register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ +#ifdef TCL_MEM_DEBUG + if (objPtr->refCount == 0x61616161) { + fprintf(stderr, "file = %s, line = %d\n", file, line); + fflush(stderr); + panic("Trying to check whether previously disposed object is shared."); + } +#endif + return ((objPtr)->refCount > 1); +} diff --git a/tcl/generic/tclParse.c b/tcl/generic/tclParse.c new file mode 100644 index 00000000000..c266f19e5e9 --- /dev/null +++ b/tcl/generic/tclParse.c @@ -0,0 +1,938 @@ +/* + * tclParse.c -- + * + * This file contains a collection of procedures that are used + * to parse Tcl commands or parts of commands (like quoted + * strings or nested sub-commands). + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Function prototypes for procedures local to this file: + */ + +static char * QuoteEnd _ANSI_ARGS_((char *string, char *lastChar, + int term)); +static char * ScriptEnd _ANSI_ARGS_((char *p, char *lastChar, + int nested)); +static char * VarNameEnd _ANSI_ARGS_((char *string, char *lastChar)); + +/* + *-------------------------------------------------------------- + * + * TclParseQuotes -- + * + * This procedure parses a double-quoted string such as a + * quoted Tcl command argument or a quoted value in a Tcl + * expression. This procedure is also used to parse array + * element names within parentheses, or anything else that + * needs all the substitutions that happen in quotes. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while parsing the + * quoted string. If an error occurs then interp->result + * contains a standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one successfully processed; this is usually the + * character just after the matching close-quote. The + * fully-substituted contents of the quotes are stored in + * standard fashion in *pvPtr, null-terminated with + * pvPtr->next pointing to the terminating null character. + * + * Side effects: + * The buffer space in pvPtr may be enlarged by calling its + * expandProc. + * + *-------------------------------------------------------------- + */ + +int +TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening double- + * quote. */ + int termChar; /* Character that terminates "quoted" string + * (usually double-quote, but sometimes + * right-paren or something else). */ + int flags; /* Flags to pass to nested Tcl_Eval calls. */ + char **termPtr; /* Store address of terminating character + * here. */ + ParseValue *pvPtr; /* Information about where to place + * fully-substituted result of parse. */ +{ + register char *src, *dst, c; + char *lastChar = string + strlen(string); + + src = string; + dst = pvPtr->next; + + while (1) { + if (dst == pvPtr->end) { + /* + * Target buffer space is about to run out. Make more space. + */ + + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 1); + dst = pvPtr->next; + } + + c = *src; + src++; + if (c == termChar) { + *dst = '\0'; + pvPtr->next = dst; + *termPtr = src; + return TCL_OK; + } else if (CHAR_TYPE(src-1, lastChar) == TCL_NORMAL) { + copy: + *dst = c; + dst++; + continue; + } else if (c == '$') { + int length; + char *value; + + value = Tcl_ParseVar(interp, src-1, termPtr); + if (value == NULL) { + return TCL_ERROR; + } + src = *termPtr; + length = strlen(value); + if ((pvPtr->end - dst) <= length) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, length); + dst = pvPtr->next; + } + strcpy(dst, value); + dst += length; + continue; + } else if (c == '[') { + int result; + + pvPtr->next = dst; + result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr); + if (result != TCL_OK) { + return result; + } + src = *termPtr; + dst = pvPtr->next; + continue; + } else if (c == '\\') { + int numRead; + + src--; + *dst = Tcl_Backslash(src, &numRead); + dst++; + src += numRead; + continue; + } else if (c == '\0') { + char buf[30]; + + Tcl_ResetResult(interp); + sprintf(buf, "missing %c", termChar); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + *termPtr = string-1; + return TCL_ERROR; + } else { + goto copy; + } + } +} + +/* + *-------------------------------------------------------------- + * + * TclParseNestedCmd -- + * + * This procedure parses a nested Tcl command between + * brackets, returning the result of the command. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while executing the + * nested command. If an error occurs then interp->result + * contains a standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one processed; this is usually the character just + * after the matching close-bracket, or the null character + * at the end of the string if the close-bracket was missing + * (a missing close bracket is an error). The result returned + * by the command is stored in standard fashion in *pvPtr, + * null-terminated, with pvPtr->next pointing to the null + * character. + * + * Side effects: + * The storage space at *pvPtr may be expanded. + * + *-------------------------------------------------------------- + */ + +int +TclParseNestedCmd(interp, string, flags, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening bracket. */ + int flags; /* Flags to pass to nested Tcl_Eval. */ + char **termPtr; /* Store address of terminating character + * here. */ + register ParseValue *pvPtr; /* Information about where to place + * result of command. */ +{ + int result, length, shortfall; + Interp *iPtr = (Interp *) interp; + + iPtr->evalFlags = flags | TCL_BRACKET_TERM; + result = Tcl_Eval(interp, string); + *termPtr = (string + iPtr->termOffset); + if (result != TCL_OK) { + /* + * The increment below results in slightly cleaner message in + * the errorInfo variable (the close-bracket will appear). + */ + + if (**termPtr == ']') { + *termPtr += 1; + } + return result; + } + (*termPtr) += 1; + length = strlen(iPtr->result); + shortfall = length + 1 - (pvPtr->end - pvPtr->next); + if (shortfall > 0) { + (*pvPtr->expandProc)(pvPtr, shortfall); + } + strcpy(pvPtr->next, iPtr->result); + pvPtr->next += length; + + Tcl_FreeResult(interp); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = '\0'; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TclParseBraces -- + * + * This procedure scans the information between matching + * curly braces. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while parsing string. + * If an error occurs then interp->result contains a + * standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one successfully processed; this is usually the + * character just after the matching close-brace. The + * information between curly braces is stored in standard + * fashion in *pvPtr, null-terminated with pvPtr->next + * pointing to the terminating null character. + * + * Side effects: + * The storage space at *pvPtr may be expanded. + * + *-------------------------------------------------------------- + */ + +int +TclParseBraces(interp, string, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening bracket. */ + char **termPtr; /* Store address of terminating character + * here. */ + register ParseValue *pvPtr; /* Information about where to place + * result of command. */ +{ + int level; + register char *src, *dst, *end; + register char c; + char *lastChar = string + strlen(string); + + src = string; + dst = pvPtr->next; + end = pvPtr->end; + level = 1; + + /* + * Copy the characters one at a time to the result area, stopping + * when the matching close-brace is found. + */ + + while (1) { + c = *src; + src++; + if (dst == end) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 20); + dst = pvPtr->next; + end = pvPtr->end; + } + *dst = c; + dst++; + if (CHAR_TYPE(src-1, lastChar) == TCL_NORMAL) { + continue; + } else if (c == '{') { + level++; + } else if (c == '}') { + level--; + if (level == 0) { + dst--; /* Don't copy the last close brace. */ + break; + } + } else if (c == '\\') { + int count; + + /* + * Must always squish out backslash-newlines, even when in + * braces. This is needed so that this sequence can appear + * anywhere in a command, such as the middle of an expression. + */ + + if (*src == '\n') { + dst[-1] = Tcl_Backslash(src-1, &count); + src += count - 1; + } else { + (void) Tcl_Backslash(src-1, &count); + while (count > 1) { + if (dst == end) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 20); + dst = pvPtr->next; + end = pvPtr->end; + } + *dst = *src; + dst++; + src++; + count--; + } + } + } else if (c == '\0') { + Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); + *termPtr = string-1; + return TCL_ERROR; + } + } + + *dst = '\0'; + pvPtr->next = dst; + *termPtr = src; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TclExpandParseValue -- + * + * This procedure is commonly used as the value of the + * expandProc in a ParseValue. It uses malloc to allocate + * more space for the result of a parse. + * + * Results: + * The buffer space in *pvPtr is reallocated to something + * larger, and if pvPtr->clientData is non-zero the old + * buffer is freed. Information is copied from the old + * buffer to the new one. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TclExpandParseValue(pvPtr, needed) + register ParseValue *pvPtr; /* Information about buffer that + * must be expanded. If the clientData + * in the structure is non-zero, it + * means that the current buffer is + * dynamically allocated. */ + int needed; /* Minimum amount of additional space + * to allocate. */ +{ + int newSpace; + char *new; + + /* + * Either double the size of the buffer or add enough new space + * to meet the demand, whichever produces a larger new buffer. + */ + + newSpace = (pvPtr->end - pvPtr->buffer) + 1; + if (newSpace < needed) { + newSpace += needed; + } else { + newSpace += newSpace; + } + new = (char *) ckalloc((unsigned) newSpace); + + /* + * Copy from old buffer to new, free old buffer if needed, and + * mark new buffer as malloc-ed. + */ + + memcpy((VOID *) new, (VOID *) pvPtr->buffer, + (size_t) (pvPtr->next - pvPtr->buffer)); + pvPtr->next = new + (pvPtr->next - pvPtr->buffer); + if (pvPtr->clientData != 0) { + ckfree(pvPtr->buffer); + } + pvPtr->buffer = new; + pvPtr->end = new + newSpace - 1; + pvPtr->clientData = (ClientData) 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclWordEnd -- + * + * Given a pointer into a Tcl command, find the end of the next + * word of the command. + * + * Results: + * The return value is a pointer to the last character that's part + * of the word pointed to by "start". If the word doesn't end + * properly within the string then the return value is the address + * of the null character at the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclWordEnd(start, lastChar, nested, semiPtr) + char *start; /* Beginning of a word of a Tcl command. */ + char *lastChar; /* Terminating character in string. */ + int nested; /* Zero means this is a top-level command. + * One means this is a nested command (close + * bracket is a word terminator). */ + int *semiPtr; /* Set to 1 if word ends with a command- + * terminating semi-colon, zero otherwise. + * If NULL then ignored. */ +{ + register char *p; + int count; + + if (semiPtr != NULL) { + *semiPtr = 0; + } + + /* + * Skip leading white space (backslash-newline must be treated like + * white-space, except that it better not be the last thing in the + * command). + */ + + for (p = start; ; p++) { + if (isspace(UCHAR(*p))) { + continue; + } + if ((p[0] == '\\') && (p[1] == '\n')) { + if (p+2 == lastChar) { + return p+2; + } + continue; + } + break; + } + + /* + * Handle words beginning with a double-quote or a brace. + */ + + if (*p == '"') { + p = QuoteEnd(p+1, lastChar, '"'); + if (p == lastChar) { + return p; + } + p++; + } else if (*p == '{') { + int braces = 1; + while (braces != 0) { + p++; + while (*p == '\\') { + (void) Tcl_Backslash(p, &count); + p += count; + } + if (*p == '}') { + braces--; + } else if (*p == '{') { + braces++; + } else if (p == lastChar) { + return p; + } + } + p++; + } + + /* + * Handle words that don't start with a brace or double-quote. + * This code is also invoked if the word starts with a brace or + * double-quote and there is garbage after the closing brace or + * quote. This is an error as far as Tcl_Eval is concerned, but + * for here the garbage is treated as part of the word. + */ + + while (1) { + if (*p == '[') { + p = ScriptEnd(p+1, lastChar, 1); + if (p == lastChar) { + return p; + } + p++; + } else if (*p == '\\') { + if (p[1] == '\n') { + /* + * Backslash-newline: it maps to a space character + * that is a word separator, so the word ends just before + * the backslash. + */ + + return p-1; + } + (void) Tcl_Backslash(p, &count); + p += count; + } else if (*p == '$') { + p = VarNameEnd(p, lastChar); + if (p == lastChar) { + return p; + } + p++; + } else if (*p == ';') { + /* + * Include the semi-colon in the word that is returned. + */ + + if (semiPtr != NULL) { + *semiPtr = 1; + } + return p; + } else if (isspace(UCHAR(*p))) { + return p-1; + } else if ((*p == ']') && nested) { + return p-1; + } else if (p == lastChar) { + if (nested) { + /* + * Nested commands can't end because of the end of the + * string. + */ + return p; + } + return p-1; + } else { + p++; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * QuoteEnd -- + * + * Given a pointer to a string that obeys the parsing conventions + * for quoted things in Tcl, find the end of that quoted thing. + * The actual thing may be a quoted argument or a parenthesized + * index name. + * + * Results: + * The return value is a pointer to the last character that is + * part of the quoted string (i.e the character that's equal to + * term). If the quoted string doesn't terminate properly then + * the return value is a pointer to the null character at the + * end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +QuoteEnd(string, lastChar, term) + char *string; /* Pointer to character just after opening + * "quote". */ + char *lastChar; /* Terminating character in string. */ + int term; /* This character will terminate the + * quoted string (e.g. '"' or ')'). */ +{ + register char *p = string; + int count; + + while (*p != term) { + if (*p == '\\') { + (void) Tcl_Backslash(p, &count); + p += count; + } else if (*p == '[') { + for (p++; *p != ']'; p++) { + p = TclWordEnd(p, lastChar, 1, (int *) NULL); + if (*p == 0) { + return p; + } + } + p++; + } else if (*p == '$') { + p = VarNameEnd(p, lastChar); + if (*p == 0) { + return p; + } + p++; + } else if (p == lastChar) { + return p; + } else { + p++; + } + } + return p-1; +} + +/* + *---------------------------------------------------------------------- + * + * VarNameEnd -- + * + * Given a pointer to a variable reference using $-notation, find + * the end of the variable name spec. + * + * Results: + * The return value is a pointer to the last character that + * is part of the variable name. If the variable name doesn't + * terminate properly then the return value is a pointer to the + * null character at the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +VarNameEnd(string, lastChar) + char *string; /* Pointer to dollar-sign character. */ + char *lastChar; /* Terminating character in string. */ +{ + register char *p = string+1; + + if (*p == '{') { + for (p++; (*p != '}') && (p != lastChar); p++) { + /* Empty loop body. */ + } + return p; + } + while (isalnum(UCHAR(*p)) || (*p == '_')) { + p++; + } + if ((*p == '(') && (p != string+1)) { + return QuoteEnd(p+1, lastChar, ')'); + } + return p-1; +} + + +/* + *---------------------------------------------------------------------- + * + * ScriptEnd -- + * + * Given a pointer to the beginning of a Tcl script, find the end of + * the script. + * + * Results: + * The return value is a pointer to the last character that's part + * of the script pointed to by "p". If the command doesn't end + * properly within the string then the return value is the address + * of the null character at the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +ScriptEnd(p, lastChar, nested) + char *p; /* Script to check. */ + char *lastChar; /* Terminating character in string. */ + int nested; /* Zero means this is a top-level command. + * One means this is a nested command (the + * last character of the script must be + * an unquoted ]). */ +{ + int commentOK = 1; + int length; + + while (1) { + while (isspace(UCHAR(*p))) { + if (*p == '\n') { + commentOK = 1; + } + p++; + } + if ((*p == '#') && commentOK) { + do { + if (*p == '\\') { + /* + * If the script ends with backslash-newline, then + * this command isn't complete. + */ + + if ((p[1] == '\n') && (p+2 == lastChar)) { + return p+2; + } + Tcl_Backslash(p, &length); + p += length; + } else { + p++; + } + } while ((p != lastChar) && (*p != '\n')); + continue; + } + p = TclWordEnd(p, lastChar, nested, &commentOK); + if (p == lastChar) { + return p; + } + p++; + if (nested) { + if (*p == ']') { + return p; + } + } else { + if (p == lastChar) { + return p-1; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ParseVar -- + * + * Given a string starting with a $ sign, parse off a variable + * name and return its value. + * + * Results: + * The return value is the contents of the variable given by + * the leading characters of string. If termPtr isn't NULL, + * *termPtr gets filled in with the address of the character + * just after the last one in the variable specifier. If the + * variable doesn't exist, then the return value is NULL and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ParseVar(interp, string, termPtr) + Tcl_Interp *interp; /* Context for looking up variable. */ + register char *string; /* String containing variable name. + * First character must be "$". */ + char **termPtr; /* If non-NULL, points to word to fill + * in with character just after last + * one in the variable specifier. */ + +{ + char *name1, *name1End, c, *result; + register char *name2; +#define NUM_CHARS 200 + char copyStorage[NUM_CHARS]; + ParseValue pv; + + /* + * There are three cases: + * 1. The $ sign is followed by an open curly brace. Then the variable + * name is everything up to the next close curly brace, and the + * variable is a scalar variable. + * 2. The $ sign is not followed by an open curly brace. Then the + * variable name is everything up to the next character that isn't + * a letter, digit, or underscore, or a "::" namespace separator. + * If the following character is an open parenthesis, then the + * information between parentheses is the array element name, which + * can include any of the substitutions permissible between quotes. + * 3. The $ sign is followed by something that isn't a letter, digit, + * underscore, or a "::" namespace separator: in this case, + * there is no variable name, and "$" is returned. + */ + + name2 = NULL; + string++; + if (*string == '{') { + string++; + name1 = string; + while (*string != '}') { + if (*string == 0) { + Tcl_SetResult(interp, "missing close-brace for variable name", + TCL_STATIC); + if (termPtr != 0) { + *termPtr = string; + } + return NULL; + } + string++; + } + name1End = string; + string++; + } else { + name1 = string; + while (isalnum(UCHAR(*string)) || (*string == '_') + || (*string == ':')) { + if (*string == ':') { + if (*(string+1) == ':') { + string += 2; /* skip over the initial :: */ + while (*string == ':') { + string++; /* skip over a subsequent : */ + } + } else { + break; /* : by itself */ + } + } else { + string++; + } + } + if (string == name1) { + if (termPtr != 0) { + *termPtr = string; + } + return "$"; + } + name1End = string; + if (*string == '(') { + char *end; + + /* + * Perform substitutions on the array element name, just as + * is done for quotes. + */ + + pv.buffer = pv.next = copyStorage; + pv.end = copyStorage + NUM_CHARS - 1; + pv.expandProc = TclExpandParseValue; + pv.clientData = (ClientData) NULL; + if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv) + != TCL_OK) { + char msg[200]; + int length; + + length = string-name1; + if (length > 100) { + length = 100; + } + sprintf(msg, "\n (parsing index for array \"%.*s\")", + length, name1); + Tcl_AddErrorInfo(interp, msg); + result = NULL; + name2 = pv.buffer; + if (termPtr != 0) { + *termPtr = end; + } + goto done; + } + Tcl_ResetResult(interp); + string = end; + name2 = pv.buffer; + } + } + if (termPtr != 0) { + *termPtr = string; + } + + c = *name1End; + *name1End = 0; + result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG); + *name1End = c; + + done: + if ((name2 != NULL) && (pv.buffer != copyStorage)) { + ckfree(pv.buffer); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CommandComplete -- + * + * Given a partial or complete Tcl command, this procedure + * determines whether the command is complete in the sense + * of having matched braces and quotes and brackets. + * + * Results: + * 1 is returned if the command is complete, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CommandComplete(cmd) + char *cmd; /* Command to check. */ +{ + char *p; + + if (*cmd == 0) { + return 1; + } + p = ScriptEnd(cmd, cmd+strlen(cmd), 0); + return (*p != 0); +} + +/* + *---------------------------------------------------------------------- + * + * TclObjCommandComplete -- + * + * Given a partial or complete Tcl command in a Tcl object, this + * procedure determines whether the command is complete in the sense of + * having matched braces and quotes and brackets. + * + * Results: + * 1 is returned if the command is complete, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclObjCommandComplete(cmdPtr) + Tcl_Obj *cmdPtr; /* Points to object holding command + * to check. */ +{ + char *cmd, *p; + int length; + + cmd = Tcl_GetStringFromObj(cmdPtr, &length); + if (length == 0) { + return 1; + } + p = ScriptEnd(cmd, cmd+length, /*nested*/ 0); + return (*p != 0); +} diff --git a/tcl/generic/tclPipe.c b/tcl/generic/tclPipe.c new file mode 100644 index 00000000000..0e958692db1 --- /dev/null +++ b/tcl/generic/tclPipe.c @@ -0,0 +1,1074 @@ +/* + * tclPipe.c -- + * + * This file contains the generic portion of the command channel + * driver as well as various utility routines used in managing + * subprocesses. + * + * Copyright (c) 1997 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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * A linked list of the following structures is used to keep track + * of child processes that have been detached but haven't exited + * yet, so we can make sure that they're properly "reaped" (officially + * waited for) and don't lie around as zombies cluttering the + * system. + */ + +typedef struct Detached { + Tcl_Pid pid; /* Id of process that's been detached + * but isn't known to have exited. */ + struct Detached *nextPtr; /* Next in list of all detached + * processes. */ +} Detached; + +static Detached *detList = NULL; /* List of all detached proceses. */ + +/* + * Declarations for local procedures defined in this file: + */ + +static TclFile FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, + char *spec, int atOk, char *arg, char *nextArg, + int flags, int *skipPtr, int *closePtr, int *releasePtr)); + +/* + *---------------------------------------------------------------------- + * + * FileForRedirect -- + * + * This procedure does much of the work of parsing redirection + * operators. It handles "@" if specified and allowed, and a file + * name, and opens the file if necessary. + * + * Results: + * The return value is the descriptor number for the file. If an + * error occurs then NULL is returned and an error message is left + * in interp->result. Several arguments are side-effected; see + * the argument list below for details. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TclFile +FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr, + releasePtr) + Tcl_Interp *interp; /* Intepreter to use for error reporting. */ + char *spec; /* Points to character just after + * redirection character. */ + char *arg; /* Pointer to entire argument containing + * spec: used for error reporting. */ + int atOK; /* Non-zero means that '@' notation can be + * used to specify a channel, zero means that + * it isn't. */ + char *nextArg; /* Next argument in argc/argv array, if needed + * for file name or channel name. May be + * NULL. */ + int flags; /* Flags to use for opening file or to + * specify mode for channel. */ + int *skipPtr; /* Filled with 1 if redirection target was + * in spec, 2 if it was in nextArg. */ + int *closePtr; /* Filled with one if the caller should + * close the file when done with it, zero + * otherwise. */ + int *releasePtr; +{ + int writing = (flags & O_WRONLY); + Tcl_Channel chan; + TclFile file; + + *skipPtr = 1; + if ((atOK != 0) && (*spec == '@')) { + spec++; + if (*spec == '\0') { + spec = nextArg; + if (spec == NULL) { + goto badLastArg; + } + *skipPtr = 2; + } + chan = Tcl_GetChannel(interp, spec, NULL); + if (chan == (Tcl_Channel) NULL) { + return NULL; + } + file = TclpMakeFile(chan, writing ? TCL_WRITABLE : TCL_READABLE); + if (file == NULL) { + Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan), + "\" wasn't opened for ", + ((writing) ? "writing" : "reading"), (char *) NULL); + return NULL; + } + *releasePtr = 1; + if (writing) { + + /* + * Be sure to flush output to the file, so that anything + * written by the child appears after stuff we've already + * written. + */ + + Tcl_Flush(chan); + } + } else { + char *name; + Tcl_DString nameString; + + if (*spec == '\0') { + spec = nextArg; + if (spec == NULL) { + goto badLastArg; + } + *skipPtr = 2; + } + name = Tcl_TranslateFileName(interp, spec, &nameString); + if (name != NULL) { + file = TclpOpenFile(name, flags); + } else { + file = NULL; + } + Tcl_DStringFree(&nameString); + if (file == NULL) { + Tcl_AppendResult(interp, "couldn't ", + ((writing) ? "write" : "read"), " file \"", spec, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return NULL; + } + *closePtr = 1; + } + return file; + + badLastArg: + Tcl_AppendResult(interp, "can't specify \"", arg, + "\" as last word in command", (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DetachPids -- + * + * This procedure is called to indicate that one or more child + * processes have been placed in background and will never be + * waited for; they should eventually be reaped by + * Tcl_ReapDetachedProcs. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DetachPids(numPids, pidPtr) + int numPids; /* Number of pids to detach: gives size + * of array pointed to by pidPtr. */ + Tcl_Pid *pidPtr; /* Array of pids to detach. */ +{ + register Detached *detPtr; + int i; + + for (i = 0; i < numPids; i++) { + detPtr = (Detached *) ckalloc(sizeof(Detached)); + detPtr->pid = pidPtr[i]; + detPtr->nextPtr = detList; + detList = detPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReapDetachedProcs -- + * + * This procedure checks to see if any detached processes have + * exited and, if so, it "reaps" them by officially waiting on + * them. It should be called "occasionally" to make sure that + * all detached processes are eventually reaped. + * + * Results: + * None. + * + * Side effects: + * Processes are waited on, so that they can be reaped by the + * system. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ReapDetachedProcs() +{ + register Detached *detPtr; + Detached *nextPtr, *prevPtr; + int status; + Tcl_Pid pid; + + for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { + pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); + if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { + prevPtr = detPtr; + detPtr = detPtr->nextPtr; + continue; + } + nextPtr = detPtr->nextPtr; + if (prevPtr == NULL) { + detList = detPtr->nextPtr; + } else { + prevPtr->nextPtr = detPtr->nextPtr; + } + ckfree((char *) detPtr); + detPtr = nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCleanupChildren -- + * + * This is a utility procedure used to wait for child processes + * to exit, record information about abnormal exits, and then + * collect any stderr output generated by them. + * + * Results: + * The return value is a standard Tcl result. If anything at + * weird happened with the child processes, TCL_ERROR is returned + * and a message is left in interp->result. + * + * Side effects: + * If the last character of interp->result is a newline, then it + * is removed unless keepNewline is non-zero. File errorId gets + * closed, and pidPtr is freed back to the storage allocator. + * + *---------------------------------------------------------------------- + */ + +int +TclCleanupChildren(interp, numPids, pidPtr, errorChan) + Tcl_Interp *interp; /* Used for error messages. */ + int numPids; /* Number of entries in pidPtr array. */ + Tcl_Pid *pidPtr; /* Array of process ids of children. */ + Tcl_Channel errorChan; /* Channel for file containing stderr output + * from pipeline. NULL means there isn't any + * stderr output. */ +{ + int result = TCL_OK; + int i, abnormalExit, anyErrorInfo; + Tcl_Pid pid; + WAIT_STATUS_TYPE waitStatus; + char *msg; + + abnormalExit = 0; + for (i = 0; i < numPids; i++) { + pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); + if (pid == (Tcl_Pid) -1) { + result = TCL_ERROR; + if (interp != (Tcl_Interp *) NULL) { + msg = Tcl_PosixError(interp); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans + * to remind people that ECHILD errors can occur on + * some systems if SIGCHLD isn't in its default state. + */ + + msg = + "child process lost (is SIGCHLD ignored or trapped?)"; + } + Tcl_AppendResult(interp, "error waiting for process to exit: ", + msg, (char *) NULL); + } + continue; + } + + /* + * Create error messages for unusual process exits. An + * extra newline gets appended to each error message, but + * it gets removed below (in the same fashion that an + * extra newline in the command's output is removed). + */ + + if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { + char msg1[20], msg2[20]; + + result = TCL_ERROR; + sprintf(msg1, "%ld", TclpGetPid(pid)); + if (WIFEXITED(waitStatus)) { + if (interp != (Tcl_Interp *) NULL) { + sprintf(msg2, "%d", WEXITSTATUS(waitStatus)); + Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, + (char *) NULL); + } + abnormalExit = 1; + } else if (WIFSIGNALED(waitStatus)) { + if (interp != (Tcl_Interp *) NULL) { + char *p; + + p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, + Tcl_SignalId((int) (WTERMSIG(waitStatus))), p, + (char *) NULL); + Tcl_AppendResult(interp, "child killed: ", p, "\n", + (char *) NULL); + } + } else if (WIFSTOPPED(waitStatus)) { + if (interp != (Tcl_Interp *) NULL) { + char *p; + + p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, + Tcl_SignalId((int) (WSTOPSIG(waitStatus))), + p, (char *) NULL); + Tcl_AppendResult(interp, "child suspended: ", p, "\n", + (char *) NULL); + } + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "child wait status didn't make sense\n", + (char *) NULL); + } + } + } + } + + /* + * Read the standard error file. If there's anything there, + * then return an error and add the file's contents to the result + * string. + */ + + anyErrorInfo = 0; + if (errorChan != NULL) { + + /* + * Make sure we start at the beginning of the file. + */ + + Tcl_Seek(errorChan, 0L, SEEK_SET); + + if (interp != (Tcl_Interp *) NULL) { + while (1) { +#define BUFFER_SIZE 1000 + char buffer[BUFFER_SIZE+1]; + int count; + + count = Tcl_Read(errorChan, buffer, BUFFER_SIZE); + if (count == 0) { + break; + } + result = TCL_ERROR; + if (count < 0) { + Tcl_AppendResult(interp, + "error reading stderr output file: ", + Tcl_PosixError(interp), (char *) NULL); + break; /* out of the "while (1)" loop. */ + } + buffer[count] = 0; + Tcl_AppendResult(interp, buffer, (char *) NULL); + anyErrorInfo = 1; + } + } + + Tcl_Close((Tcl_Interp *) NULL, errorChan); + } + + /* + * If a child exited abnormally but didn't output any error information + * at all, generate an error message here. + */ + + if (abnormalExit && !anyErrorInfo && (interp != (Tcl_Interp *) NULL)) { + Tcl_AppendResult(interp, "child process exited abnormally", + (char *) NULL); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreatePipeline -- + * + * Given an argc/argv array, instantiate a pipeline of processes + * as described by the argv. + * + * This procedure is unofficially exported for use by BLT. + * + * Results: + * The return value is a count of the number of new processes + * created, or -1 if an error occurred while creating the pipeline. + * *pidArrayPtr is filled in with the address of a dynamically + * allocated array giving the ids of all of the processes. It + * is up to the caller to free this array when it isn't needed + * anymore. If inPipePtr is non-NULL, *inPipePtr is filled in + * with the file id for the input pipe for the pipeline (if any): + * the caller must eventually close this file. If outPipePtr + * isn't NULL, then *outPipePtr is filled in with the file id + * for the output pipe from the pipeline: the caller must close + * this file. If errFilePtr isn't NULL, then *errFilePtr is filled + * with a file id that may be used to read error output after the + * pipeline completes. + * + * Side effects: + * Processes and pipes are created. + * + *---------------------------------------------------------------------- + */ + +int +TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, + outPipePtr, errFilePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + int argc; /* Number of entries in argv. */ + char **argv; /* Array of strings describing commands in + * pipeline plus I/O redirection with <, + * <<, >, etc. Argv[argc] must be NULL. */ + Tcl_Pid **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with + * address of array of pids for processes + * in pipeline (first pid is first process + * in pipeline). */ + TclFile *inPipePtr; /* If non-NULL, input to the pipeline comes + * from a pipe (unless overridden by + * redirection in the command). The file + * id with which to write to this pipe is + * stored at *inPipePtr. NULL means command + * specified its own input source. */ + TclFile *outPipePtr; /* If non-NULL, output to the pipeline goes + * to a pipe, unless overriden by redirection + * in the command. The file id with which to + * read frome this pipe is stored at + * *outPipePtr. NULL means command specified + * its own output sink. */ + TclFile *errFilePtr; /* If non-NULL, all stderr output from the + * pipeline will go to a temporary file + * created here, and a descriptor to read + * the file will be left at *errFilePtr. + * The file will be removed already, so + * closing this descriptor will be the end + * of the file. If this is NULL, then + * all stderr output goes to our stderr. + * If the pipeline specifies redirection + * then the file will still be created + * but it will never get any data. */ +{ + Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all + * the pids of child processes. */ + int numPids; /* Actual number of processes that exist + * at *pidPtr right now. */ + int cmdCount; /* Count of number of distinct commands + * found in argc/argv. */ + char *inputLiteral = NULL; /* If non-null, then this points to a + * string containing input data (specified + * via <<) to be piped to the first process + * in the pipeline. */ + TclFile inputFile = NULL; /* If != NULL, gives file to use as input for + * first process in pipeline (specified via < + * or <@). */ + int inputClose = 0; /* If non-zero, then inputFile should be + * closed when cleaning up. */ + int inputRelease = 0; + TclFile outputFile = NULL; /* Writable file for output from last command + * in pipeline (could be file or pipe). NULL + * means use stdout. */ + int outputClose = 0; /* If non-zero, then outputFile should be + * closed when cleaning up. */ + int outputRelease = 0; + TclFile errorFile = NULL; /* Writable file for error output from all + * commands in pipeline. NULL means use + * stderr. */ + int errorClose = 0; /* If non-zero, then errorFile should be + * closed when cleaning up. */ + int errorRelease = 0; + int joinError = 0; /* CYGNUS LOCAL: If non-zero, join stderr + * and stdout. */ + char *p; + int skip, lastBar, lastArg, i, j, atOK, flags, errorToOutput; + Tcl_DString execBuffer; + TclFile pipeIn; + TclFile curInFile, curOutFile, curErrFile; + Tcl_Channel channel; + + if (inPipePtr != NULL) { + *inPipePtr = NULL; + } + if (outPipePtr != NULL) { + *outPipePtr = NULL; + } + if (errFilePtr != NULL) { + *errFilePtr = NULL; + } + + Tcl_DStringInit(&execBuffer); + + pipeIn = NULL; + curInFile = NULL; + curOutFile = NULL; + numPids = 0; + + /* + * First, scan through all the arguments to figure out the structure + * of the pipeline. Process all of the input and output redirection + * arguments and remove them from the argument list in the pipeline. + * Count the number of distinct processes (it's the number of "|" + * arguments plus one) but don't remove the "|" arguments because + * they'll be used in the second pass to seperate the individual + * child processes. Cannot start the child processes in this pass + * because the redirection symbols may appear anywhere in the + * command line -- e.g., the '<' that specifies the input to the + * entire pipe may appear at the very end of the argument list. + */ + + lastBar = -1; + cmdCount = 1; + for (i = 0; i < argc; i++) { + skip = 0; + p = argv[i]; + switch (*p++) { + case '|': + if (*p == '&') { + p++; + } + if (*p == '\0') { + if ((i == (lastBar + 1)) || (i == (argc - 1))) { + Tcl_SetResult(interp, + "illegal use of | or |& in command", + TCL_STATIC); + goto error; + } + } + lastBar = i; + cmdCount++; + break; + + case '<': + if (inputClose != 0) { + inputClose = 0; + TclpCloseFile(inputFile); + } + if (inputRelease != 0) { + inputRelease = 0; + TclpReleaseFile(inputFile); + } + if (*p == '<') { + inputFile = NULL; + inputLiteral = p + 1; + skip = 1; + if (*inputLiteral == '\0') { + inputLiteral = argv[i + 1]; + if (inputLiteral == NULL) { + Tcl_AppendResult(interp, "can't specify \"", argv[i], + "\" as last word in command", (char *) NULL); + goto error; + } + skip = 2; + } + } else { + inputLiteral = NULL; + inputFile = FileForRedirect(interp, p, 1, argv[i], + argv[i + 1], O_RDONLY, &skip, &inputClose, &inputRelease); + if (inputFile == NULL) { + goto error; + } + } + break; + + case '>': + atOK = 1; + flags = O_WRONLY | O_CREAT | O_TRUNC; + errorToOutput = 0; + if (*p == '>') { + p++; + atOK = 0; + flags = O_WRONLY | O_CREAT; + } + if (*p == '&') { + if (errorClose != 0) { + errorClose = 0; + TclpCloseFile(errorFile); + } + errorToOutput = 1; + p++; + } + + /* + * Close the old output file, but only if the error file is + * not also using it. + */ + + if (outputClose != 0) { + outputClose = 0; + if (errorFile == outputFile) { + errorClose = 1; + } else { + TclpCloseFile(outputFile); + } + } + if (outputRelease != 0) { + outputRelease = 0; + if (errorFile == outputFile) { + errorRelease = 1; + } else { + TclpReleaseFile(outputFile); + } + } + outputFile = FileForRedirect(interp, p, atOK, argv[i], + argv[i + 1], flags, &skip, &outputClose, &outputRelease); + if (outputFile == NULL) { + goto error; + } + if (errorToOutput) { + if (errorClose != 0) { + errorClose = 0; + TclpCloseFile(errorFile); + } + if (errorRelease != 0) { + errorRelease = 0; + TclpReleaseFile(errorFile); + } + errorFile = outputFile; + } + break; + + case '2': + if (*p != '>') { + break; + } + p++; + atOK = 1; + flags = O_WRONLY | O_CREAT | O_TRUNC; + if (*p == '>') { + p++; + atOK = 0; + flags = O_WRONLY | O_CREAT; + } + if (errorClose != 0) { + errorClose = 0; + TclpCloseFile(errorFile); + } + if (errorRelease != 0) { + errorRelease = 0; + TclpReleaseFile(errorFile); + } + + /* CYGNUS LOCAL: On windows we need to handle redirecting + stderr to stdout specially. On Unix it works out + because TclpCreateProcess happens to dup stderr to + stdout after reopening stdout, but that fails on + Windows. */ + joinError = 0; + if (*p == '@' + && strcmp ((p[1] == '\0' ? argv[i + 1] : p + 1), + "stdout") == 0) { + joinError = 1; + if (p[1] == '\0') { + skip = 2; + } else { + skip = 1; + } + } else { + errorFile = FileForRedirect(interp, p, atOK, argv[i], + argv[i + 1], flags, &skip, &errorClose, &errorRelease); + if (errorFile == NULL) { + goto error; + } + } + break; + } + + if (skip != 0) { + for (j = i + skip; j < argc; j++) { + argv[j - skip] = argv[j]; + } + argc -= skip; + i -= 1; + } + } + + if (inputFile == NULL) { + if (inputLiteral != NULL) { + /* + * The input for the first process is immediate data coming from + * Tcl. Create a temporary file for it and put the data into the + * file. + */ + inputFile = TclpCreateTempFile(inputLiteral, NULL); + if (inputFile == NULL) { + Tcl_AppendResult(interp, + "couldn't create input file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + inputClose = 1; + } else if (inPipePtr != NULL) { + /* + * The input for the first process in the pipeline is to + * come from a pipe that can be written from by the caller. + */ + + if (TclpCreatePipe(&inputFile, inPipePtr) == 0) { + Tcl_AppendResult(interp, + "couldn't create input pipe for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + inputClose = 1; + } else { + /* + * The input for the first process comes from stdin. + */ + + channel = Tcl_GetStdChannel(TCL_STDIN); + if (channel != NULL) { + inputFile = TclpMakeFile(channel, TCL_READABLE); + if (inputFile != NULL) { + inputRelease = 1; + } + } + } + } + + if (outputFile == NULL) { + if (outPipePtr != NULL) { + /* + * Output from the last process in the pipeline is to go to a + * pipe that can be read by the caller. + */ + + if (TclpCreatePipe(outPipePtr, &outputFile) == 0) { + Tcl_AppendResult(interp, + "couldn't create output pipe for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + outputClose = 1; + } else { + /* + * The output for the last process goes to stdout. + */ + + channel = Tcl_GetStdChannel(TCL_STDOUT); + if (channel) { + outputFile = TclpMakeFile(channel, TCL_WRITABLE); + if (outputFile != NULL) { + outputRelease = 1; + } + } + } + } + + if (errorFile == NULL) { + /* CYGNUS LOCAL: Handle joinError. */ + if (joinError) { + errorFile = outputFile; + } else if (errFilePtr != NULL) { + /* + * Set up the standard error output sink for the pipeline, if + * requested. Use a temporary file which is opened, then deleted. + * Could potentially just use pipe, but if it filled up it could + * cause the pipeline to deadlock: we'd be waiting for processes + * to complete before reading stderr, and processes couldn't + * complete because stderr was backed up. + */ + + errorFile = TclpCreateTempFile(NULL, NULL); + if (errorFile == NULL) { + Tcl_AppendResult(interp, + "couldn't create error file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + *errFilePtr = errorFile; + } else { + /* + * Errors from the pipeline go to stderr. + */ + + channel = Tcl_GetStdChannel(TCL_STDERR); + if (channel) { + errorFile = TclpMakeFile(channel, TCL_WRITABLE); + if (errorFile != NULL) { + errorRelease = 1; + } + } + } + } + + /* + * Scan through the argc array, creating a process for each + * group of arguments between the "|" characters. + */ + + Tcl_ReapDetachedProcs(); + pidPtr = (Tcl_Pid *) ckalloc((unsigned) (cmdCount * sizeof(Tcl_Pid))); + + curInFile = inputFile; + + for (i = 0; i < argc; i = lastArg + 1) { + int joinThisError; + Tcl_Pid pid; + + /* + * Convert the program name into native form. + */ + + argv[i] = Tcl_TranslateFileName(interp, argv[i], &execBuffer); + if (argv[i] == NULL) { + goto error; + } + + /* + * Find the end of the current segment of the pipeline. + */ + + joinThisError = 0; + for (lastArg = i; lastArg < argc; lastArg++) { + if (argv[lastArg][0] == '|') { + if (argv[lastArg][1] == '\0') { + break; + } + if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == '\0')) { + joinThisError = 1; + break; + } + } + } + argv[lastArg] = NULL; + + /* + * If this is the last segment, use the specified outputFile. + * Otherwise create an intermediate pipe. pipeIn will become the + * curInFile for the next segment of the pipe. + */ + + if (lastArg == argc) { + curOutFile = outputFile; + } else { + if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) { + Tcl_AppendResult(interp, "couldn't create pipe: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + } + + if (joinThisError != 0) { + curErrFile = curOutFile; + } else { + curErrFile = errorFile; + } + + if (TclpCreateProcess(interp, lastArg - i, argv + i, + curInFile, curOutFile, curErrFile, &pid) != TCL_OK) { + goto error; + } + Tcl_DStringFree(&execBuffer); + + pidPtr[numPids] = pid; + numPids++; + + /* + * Close off our copies of file descriptors that were set up for + * this child, then set up the input for the next child. + */ + + if ((curInFile != NULL) && (curInFile != inputFile)) { + TclpCloseFile(curInFile); + } + curInFile = pipeIn; + pipeIn = NULL; + + if ((curOutFile != NULL) && (curOutFile != outputFile)) { + TclpCloseFile(curOutFile); + } + curOutFile = NULL; + } + + *pidArrayPtr = pidPtr; + + /* + * All done. Cleanup open files lying around and then return. + */ + +cleanup: + Tcl_DStringFree(&execBuffer); + + if (inputClose) { + TclpCloseFile(inputFile); + } else if (inputRelease) { + TclpReleaseFile(inputFile); + } + if (outputClose) { + TclpCloseFile(outputFile); + } else if (outputRelease) { + TclpReleaseFile(outputFile); + } + if (errorClose) { + TclpCloseFile(errorFile); + } else if (errorRelease) { + TclpReleaseFile(errorFile); + } + return numPids; + + /* + * An error occurred. There could have been extra files open, such + * as pipes between children. Clean them all up. Detach any child + * processes that have been created. + */ + +error: + if (pipeIn != NULL) { + TclpCloseFile(pipeIn); + } + if ((curOutFile != NULL) && (curOutFile != outputFile)) { + TclpCloseFile(curOutFile); + } + if ((curInFile != NULL) && (curInFile != inputFile)) { + TclpCloseFile(curInFile); + } + if ((inPipePtr != NULL) && (*inPipePtr != NULL)) { + TclpCloseFile(*inPipePtr); + *inPipePtr = NULL; + } + if ((outPipePtr != NULL) && (*outPipePtr != NULL)) { + TclpCloseFile(*outPipePtr); + *outPipePtr = NULL; + } + if ((errFilePtr != NULL) && (*errFilePtr != NULL)) { + TclpCloseFile(*errFilePtr); + *errFilePtr = NULL; + } + if (pidPtr != NULL) { + for (i = 0; i < numPids; i++) { + if (pidPtr[i] != (Tcl_Pid) -1) { + Tcl_DetachPids(1, &pidPtr[i]); + } + } + ckfree((char *) pidPtr); + } + numPids = -1; + goto cleanup; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenCommandChannel -- + * + * Opens an I/O channel to one or more subprocesses specified + * by argc and argv. The flags argument determines the + * disposition of the stdio handles. If the TCL_STDIN flag is + * set then the standard input for the first subprocess will + * be tied to the channel: writing to the channel will provide + * input to the subprocess. If TCL_STDIN is not set, then + * standard input for the first subprocess will be the same as + * this application's standard input. If TCL_STDOUT is set then + * standard output from the last subprocess can be read from the + * channel; otherwise it goes to this application's standard + * output. If TCL_STDERR is set, standard error output for all + * subprocesses is returned to the channel and results in an error + * when the channel is closed; otherwise it goes to this + * application's standard error. If TCL_ENFORCE_MODE is not set, + * then argc and argv can redirect the stdio handles to override + * TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it + * is an error for argc and argv to override stdio channels for + * which TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set. + * + * Results: + * A new command channel, or NULL on failure with an error + * message left in interp. + * + * Side effects: + * Creates processes, opens pipes. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenCommandChannel(interp, argc, argv, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. Can + * NOT be NULL. */ + int argc; /* How many arguments. */ + char **argv; /* Array of arguments for command pipe. */ + int flags; /* Or'ed combination of TCL_STDIN, TCL_STDOUT, + * TCL_STDERR, and TCL_ENFORCE_MODE. */ +{ + TclFile *inPipePtr, *outPipePtr, *errFilePtr; + TclFile inPipe, outPipe, errFile; + int numPids; + Tcl_Pid *pidPtr; + Tcl_Channel channel; + + inPipe = outPipe = errFile = NULL; + + inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL; + outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL; + errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL; + + numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr, + outPipePtr, errFilePtr); + + if (numPids < 0) { + goto error; + } + + /* + * Verify that the pipes that were created satisfy the + * readable/writable constraints. + */ + + if (flags & TCL_ENFORCE_MODE) { + if ((flags & TCL_STDOUT) && (outPipe == NULL)) { + Tcl_AppendResult(interp, "can't read output from command:", + " standard output was redirected", (char *) NULL); + goto error; + } + if ((flags & TCL_STDIN) && (inPipe == NULL)) { + Tcl_AppendResult(interp, "can't write input to command:", + " standard input was redirected", (char *) NULL); + goto error; + } + } + + channel = TclpCreateCommandChannel(outPipe, inPipe, errFile, + numPids, pidPtr); + + if (channel == (Tcl_Channel) NULL) { + Tcl_AppendResult(interp, "pipe for command could not be created", + (char *) NULL); + goto error; + } + return channel; + +error: + if (numPids > 0) { + Tcl_DetachPids(numPids, pidPtr); + ckfree((char *) pidPtr); + } + if (inPipe != NULL) { + TclpCloseFile(inPipe); + } + if (outPipe != NULL) { + TclpCloseFile(outPipe); + } + if (errFile != NULL) { + TclpCloseFile(errFile); + } + return NULL; +} diff --git a/tcl/generic/tclPkg.c b/tcl/generic/tclPkg.c new file mode 100644 index 00000000000..e74356185c4 --- /dev/null +++ b/tcl/generic/tclPkg.c @@ -0,0 +1,734 @@ +/* + * tclPkg.c -- + * + * This file implements package and version control for Tcl via + * the "package" command and a few C APIs. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * Each invocation of the "package ifneeded" command creates a structure + * of the following type, which is used to load the package into the + * interpreter if it is requested with a "package require" command. + */ + +typedef struct PkgAvail { + char *version; /* Version string; malloc'ed. */ + char *script; /* Script to invoke to provide this version + * of the package. Malloc'ed and protected + * by Tcl_Preserve and Tcl_Release. */ + struct PkgAvail *nextPtr; /* Next in list of available versions of + * the same package. */ +} PkgAvail; + +/* + * For each package that is known in any way to an interpreter, there + * is one record of the following type. These records are stored in + * the "packageTable" hash table in the interpreter, keyed by + * package name such as "Tk" (no version number). + */ + +typedef struct Package { + char *version; /* Version that has been supplied in this + * interpreter via "package provide" + * (malloc'ed). NULL means the package doesn't + * exist in this interpreter yet. */ + PkgAvail *availPtr; /* First in list of all available versions + * of this package. */ +} Package; + +/* + * Prototypes for procedures defined in this file: + */ + +static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +static int ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2, + int *satPtr)); +static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, + char *name)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgProvide -- + * + * This procedure is invoked to declare that a particular version + * of a particular package is now present in an interpreter. There + * must not be any other version of this package already + * provided in the interpreter. + * + * Results: + * Normally returns TCL_OK; if there is already another version + * of the package loaded then TCL_ERROR is returned and an error + * message is left in interp->result. + * + * Side effects: + * The interpreter remembers that this package is available, + * so that no other version of the package may be provided for + * the interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_PkgProvide(interp, name, version) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + char *name; /* Name of package. */ + char *version; /* Version string for package. */ +{ + Package *pkgPtr; + + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version == NULL) { + pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1)); + strcpy(pkgPtr->version, version); + return TCL_OK; + } + if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) { + return TCL_OK; + } + Tcl_AppendResult(interp, "conflicting versions provided for package \"", + name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgRequire -- + * + * This procedure is called by code that depends on a particular + * version of a particular package. If the package is not already + * provided in the interpreter, this procedure invokes a Tcl script + * to provide it. If the package is already provided, this + * procedure makes sure that the caller's needs don't conflict with + * the version that is present. + * + * Results: + * If successful, returns the version string for the currently + * provided version of the package, which may be different from + * the "version" argument. If the caller's requirements + * cannot be met (e.g. the version requested conflicts with + * a currently provided version, or the required version cannot + * be found, or the script to provide the required version + * generates an error), NULL is returned and an error + * message is left in interp->result. + * + * Side effects: + * The script from some previous "package ifneeded" command may + * be invoked to provide the package. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_PkgRequire(interp, name, version, exact) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + char *name; /* Name of desired package. */ + char *version; /* Version string for desired version; + * NULL means use the latest version + * available. */ + int exact; /* Non-zero means that only the particular + * version given is acceptable. Zero means + * use the latest compatible version. */ +{ + Package *pkgPtr; + PkgAvail *availPtr, *bestPtr; + char *script; + int code, satisfies, result, pass; + Tcl_DString command; + + /* + * It can take up to three passes to find the package: one pass to + * run the "package unknown" script, one to run the "package ifneeded" + * script for a specific version, and a final pass to lookup the + * package loaded by the "package ifneeded" script. + */ + + for (pass = 1; ; pass++) { + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version != NULL) { + break; + } + + /* + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. + */ + + bestPtr = NULL; + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version, + bestPtr->version, (int *) NULL) <= 0)) { + continue; + } + if (version != NULL) { + result = ComparePkgVersions(availPtr->version, version, + &satisfies); + if ((result != 0) && exact) { + continue; + } + if (!satisfies) { + continue; + } + } + bestPtr = availPtr; + } + if (bestPtr != NULL) { + /* + * We found an ifneeded script for the package. Be careful while + * executing it: this could cause reentrancy, so (a) protect the + * script itself from deletion and (b) don't assume that bestPtr + * will still exist when the script completes. + */ + + script = bestPtr->script; + Tcl_Preserve((ClientData) script); + code = Tcl_GlobalEval(interp, script); + Tcl_Release((ClientData) script); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package ifneeded\" script)"); + } + return NULL; + } + Tcl_ResetResult(interp); + pkgPtr = FindPackage(interp, name); + break; + } + + /* + * Package not in the database. If there is a "package unknown" + * command, invoke it (but only on the first pass; after that, + * we should not get here in the first place). + */ + + if (pass > 1) { + break; + } + script = ((Interp *) interp)->packageUnknown; + if (script != NULL) { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + Tcl_DStringAppend(&command, " ", 1); + Tcl_DStringAppend(&command, (version != NULL) ? version : "{}", + -1); + if (exact) { + Tcl_DStringAppend(&command, " -exact", 7); + } + code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command)); + Tcl_DStringFree(&command); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + } + return NULL; + } + Tcl_ResetResult(interp); + } + } + + if (pkgPtr->version == NULL) { + Tcl_AppendResult(interp, "can't find package ", name, + (char *) NULL); + if (version != NULL) { + Tcl_AppendResult(interp, " ", version, (char *) NULL); + } + return NULL; + } + + /* + * At this point we now that the package is present. Make sure that the + * provided version meets the current requirement. + */ + + if (version == NULL) { + return pkgPtr->version; + } + result = ComparePkgVersions(pkgPtr->version, version, &satisfies); + if ((satisfies && !exact) || (result == 0)) { + return pkgPtr->version; + } + Tcl_AppendResult(interp, "version conflict for package \"", + name, "\": have ", pkgPtr->version, ", need ", version, + (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PackageCmd -- + * + * This procedure is invoked to process the "package" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PackageCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Interp *iPtr = (Interp *) interp; + size_t length; + int c, exact, i, satisfies; + PkgAvail *availPtr, *prevPtr; + Package *pkgPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable *tablePtr; + char *version; + char buf[30]; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) { + for (i = 2; i < argc; i++) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[i]); + if (hPtr == NULL) { + return TCL_OK; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); + } + } else if ((c == 'i') && (strncmp(argv[1], "ifneeded", length) == 0)) { + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ifneeded package version ?script?\"", (char *) NULL); + return TCL_ERROR; + } + if (CheckVersion(interp, argv[3]) != TCL_OK) { + return TCL_ERROR; + } + if (argc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr == NULL) { + return TCL_OK; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } else { + pkgPtr = FindPackage(interp, argv[2]); + } + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + if (ComparePkgVersions(availPtr->version, argv[3], (int *) NULL) + == 0) { + if (argc == 4) { + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); + return TCL_OK; + } + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + break; + } + } + if (argc == 4) { + return TCL_OK; + } + if (availPtr == NULL) { + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr->version = ckalloc((unsigned) (strlen(argv[3]) + 1)); + strcpy(availPtr->version, argv[3]); + if (prevPtr == NULL) { + availPtr->nextPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr; + } else { + availPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = availPtr; + } + } + availPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); + strcpy(availPtr->script, argv[4]); + } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " names\"", (char *) NULL); + return TCL_ERROR; + } + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + } + } + } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0)) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " provide package ?version?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + } + } + return TCL_OK; + } + if (CheckVersion(interp, argv[3]) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvide(interp, argv[2], argv[3]); + } else if ((c == 'r') && (strncmp(argv[1], "require", length) == 0)) { + if (argc < 3) { + requireSyntax: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " require ?-exact? package ?version?\"", (char *) NULL); + return TCL_ERROR; + } + if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (argc == (4+exact)) { + version = argv[3+exact]; + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((argc != 3) || exact) { + goto requireSyntax; + } + version = Tcl_PkgRequire(interp, argv[2+exact], version, exact); + if (version == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, version, TCL_VOLATILE); + } else if ((c == 'u') && (strncmp(argv[1], "unknown", length) == 0)) { + if (argc == 2) { + if (iPtr->packageUnknown != NULL) { + Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); + } + } else if (argc == 3) { + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } + if (argv[2][0] == 0) { + iPtr->packageUnknown = NULL; + } else { + iPtr->packageUnknown = (char *) ckalloc((unsigned) + (strlen(argv[2]) + 1)); + strcpy(iPtr->packageUnknown, argv[2]); + } + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " unknown ?command?\"", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'v') && (strncmp(argv[1], "vcompare", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " vcompare version1 version2\"", (char *) NULL); + return TCL_ERROR; + } + if ((CheckVersion(interp, argv[2]) != TCL_OK) + || (CheckVersion(interp, argv[3]) != TCL_OK)) { + return TCL_ERROR; + } + TclFormatInt(buf, ComparePkgVersions(argv[2], argv[3], (int *) NULL)); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else if ((c == 'v') && (strncmp(argv[1], "versions", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " versions package\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); + } + } + } else if ((c == 'v') && (strncmp(argv[1], "vsatisfies", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " vsatisfies version1 version2\"", (char *) NULL); + return TCL_ERROR; + } + if ((CheckVersion(interp, argv[2]) != TCL_OK) + || (CheckVersion(interp, argv[3]) != TCL_OK)) { + return TCL_ERROR; + } + ComparePkgVersions(argv[2], argv[3], &satisfies); + TclFormatInt(buf, satisfies); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be forget, ifneeded, names, ", + "provide, require, unknown, vcompare, ", + "versions, or vsatisfies", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FindPackage -- + * + * This procedure finds the Package record for a particular package + * in a particular interpreter, creating a record if one doesn't + * already exist. + * + * Results: + * The return value is a pointer to the Package record for the + * package. + * + * Side effects: + * A new Package record may be created. + * + *---------------------------------------------------------------------- + */ + +static Package * +FindPackage(interp, name) + Tcl_Interp *interp; /* Interpreter to use for package lookup. */ + char *name; /* Name of package to fine. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + int new; + Package *pkgPtr; + + hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new); + if (new) { + pkgPtr = (Package *) ckalloc(sizeof(Package)); + pkgPtr->version = NULL; + pkgPtr->availPtr = NULL; + Tcl_SetHashValue(hPtr, pkgPtr); + } else { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } + return pkgPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclFreePackageInfo -- + * + * This procedure is called during interpreter deletion to + * free all of the package-related information for the + * interpreter. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclFreePackageInfo(iPtr) + Interp *iPtr; /* Interpereter that is being deleted. */ +{ + Package *pkgPtr; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + PkgAvail *availPtr; + + for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); + } + Tcl_DeleteHashTable(&iPtr->packageTable); + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } +} + +/* + *---------------------------------------------------------------------- + * + * CheckVersion -- + * + * This procedure checks to see whether a version number has + * valid syntax. + * + * Results: + * If string is a properly formed version number the TCL_OK + * is returned. Otherwise TCL_ERROR is returned and an error + * message is left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CheckVersion(interp, string) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* Supposedly a version number, which is + * groups of decimal digits separated + * by dots. */ +{ + char *p = string; + + if (!isdigit(UCHAR(*p))) { + goto error; + } + for (p++; *p != 0; p++) { + if (!isdigit(UCHAR(*p)) && (*p != '.')) { + goto error; + } + } + if (p[-1] != '.') { + return TCL_OK; + } + + error: + Tcl_AppendResult(interp, "expected version number but got \"", + string, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ComparePkgVersions -- + * + * This procedure compares two version numbers. + * + * Results: + * The return value is -1 if v1 is less than v2, 0 if the two + * version numbers are the same, and 1 if v1 is greater than v2. + * If *satPtr is non-NULL, the word it points to is filled in + * with 1 if v2 >= v1 and both numbers have the same major number + * or 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ComparePkgVersions(v1, v2, satPtr) + char *v1, *v2; /* Versions strings, of form 2.1.3 (any + * number of version numbers). */ + int *satPtr; /* If non-null, the word pointed to is + * filled in with a 0/1 value. 1 means + * v1 "satisfies" v2: v1 is greater than + * or equal to v2 and both version numbers + * have the same major number. */ +{ + int thisIsMajor, n1, n2; + + /* + * Each iteration of the following loop processes one number from + * each string, terminated by a ".". If those numbers don't match + * then the comparison is over; otherwise, we loop back for the + * next number. + */ + + thisIsMajor = 1; + while (1) { + /* + * Parse one decimal number from the front of each string. + */ + + n1 = n2 = 0; + while ((*v1 != 0) && (*v1 != '.')) { + n1 = 10*n1 + (*v1 - '0'); + v1++; + } + while ((*v2 != 0) && (*v2 != '.')) { + n2 = 10*n2 + (*v2 - '0'); + v2++; + } + + /* + * Compare and go on to the next version number if the + * current numbers match. + */ + + if (n1 != n2) { + break; + } + if (*v1 != 0) { + v1++; + } else if (*v2 == 0) { + break; + } + if (*v2 != 0) { + v2++; + } + thisIsMajor = 0; + } + if (satPtr != NULL) { + *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor); + } + if (n1 > n2) { + return 1; + } else if (n1 == n2) { + return 0; + } else { + return -1; + } +} diff --git a/tcl/generic/tclPort.h b/tcl/generic/tclPort.h new file mode 100644 index 00000000000..d6620dc1b69 --- /dev/null +++ b/tcl/generic/tclPort.h @@ -0,0 +1,33 @@ +/* + * tclPort.h -- + * + * This header file handles porting issues that occur because + * of differences between systems. It reads in platform specific + * portability files. + * + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#ifndef _TCLPORT +#define _TCLPORT + +#if defined(__CYGWIN__) && defined(__TCL_UNIX_VARIANT) +# include "../unix/tclUnixPort.h" +#else +#if defined(__WIN32__) || defined(_WIN32) +# include "../win/tclWinPort.h" +#else +# if defined(MAC_TCL) +# include "tclMacPort.h" +# else +# include "../unix/tclUnixPort.h" +# endif +#endif +#endif + +#endif /* _TCLPORT */ diff --git a/tcl/generic/tclPosixStr.c b/tcl/generic/tclPosixStr.c new file mode 100644 index 00000000000..d2649b56c2c --- /dev/null +++ b/tcl/generic/tclPosixStr.c @@ -0,0 +1,1174 @@ +/* + * tclPosixStr.c -- + * + * This file contains procedures that generate strings + * corresponding to various POSIX-related codes, such + * as errno and signals. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrnoId -- + * + * Return a textual identifier for the current errno value. + * + * Results: + * This procedure returns a machine-readable textual identifier + * that corresponds to the current errno value (e.g. "EPERM"). + * The identifier is the same as the #define name in errno.h. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ErrnoId() +{ + switch (errno) { +#ifdef E2BIG + case E2BIG: return "E2BIG"; +#endif +#ifdef EACCES + case EACCES: return "EACCES"; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: return "EADDRINUSE"; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; +#endif +#ifdef EADV + case EADV: return "EADV"; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: return "EAFNOSUPPORT"; +#endif +#ifdef EAGAIN + case EAGAIN: return "EAGAIN"; +#endif +#ifdef EALIGN + case EALIGN: return "EALIGN"; +#endif +#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) + case EALREADY: return "EALREADY"; +#endif +#ifdef EBADE + case EBADE: return "EBADE"; +#endif +#ifdef EBADF + case EBADF: return "EBADF"; +#endif +#ifdef EBADFD + case EBADFD: return "EBADFD"; +#endif +#ifdef EBADMSG + case EBADMSG: return "EBADMSG"; +#endif +#ifdef EBADR + case EBADR: return "EBADR"; +#endif +#ifdef EBADRPC + case EBADRPC: return "EBADRPC"; +#endif +#ifdef EBADRQC + case EBADRQC: return "EBADRQC"; +#endif +#ifdef EBADSLT + case EBADSLT: return "EBADSLT"; +#endif +#ifdef EBFONT + case EBFONT: return "EBFONT"; +#endif +#ifdef EBUSY + case EBUSY: return "EBUSY"; +#endif +#ifdef ECHILD + case ECHILD: return "ECHILD"; +#endif +#ifdef ECHRNG + case ECHRNG: return "ECHRNG"; +#endif +#ifdef ECOMM + case ECOMM: return "ECOMM"; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: return "ECONNABORTED"; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: return "ECONNREFUSED"; +#endif +#ifdef ECONNRESET + case ECONNRESET: return "ECONNRESET"; +#endif +#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) + case EDEADLK: return "EDEADLK"; +#endif +#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK)) + case EDEADLOCK: return "EDEADLOCK"; +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: return "EDESTADDRREQ"; +#endif +#ifdef EDIRTY + case EDIRTY: return "EDIRTY"; +#endif +#ifdef EDOM + case EDOM: return "EDOM"; +#endif +#ifdef EDOTDOT + case EDOTDOT: return "EDOTDOT"; +#endif +#ifdef EDQUOT + case EDQUOT: return "EDQUOT"; +#endif +#ifdef EDUPPKG + case EDUPPKG: return "EDUPPKG"; +#endif +#ifdef EEXIST + case EEXIST: return "EEXIST"; +#endif +#ifdef EFAULT + case EFAULT: return "EFAULT"; +#endif +#ifdef EFBIG + case EFBIG: return "EFBIG"; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: return "EHOSTDOWN"; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: return "EHOSTUNREACH"; +#endif +#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) + case EIDRM: return "EIDRM"; +#endif +#ifdef EINIT + case EINIT: return "EINIT"; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: return "EINPROGRESS"; +#endif +#ifdef EINTR + case EINTR: return "EINTR"; +#endif +#ifdef EINVAL + case EINVAL: return "EINVAL"; +#endif +#ifdef EIO + case EIO: return "EIO"; +#endif +#ifdef EISCONN + case EISCONN: return "EISCONN"; +#endif +#ifdef EISDIR + case EISDIR: return "EISDIR"; +#endif +#ifdef EISNAME + case EISNAM: return "EISNAM"; +#endif +#ifdef ELBIN + case ELBIN: return "ELBIN"; +#endif +#ifdef EL2HLT + case EL2HLT: return "EL2HLT"; +#endif +#ifdef EL2NSYNC + case EL2NSYNC: return "EL2NSYNC"; +#endif +#ifdef EL3HLT + case EL3HLT: return "EL3HLT"; +#endif +#ifdef EL3RST + case EL3RST: return "EL3RST"; +#endif +#ifdef ELIBACC + case ELIBACC: return "ELIBACC"; +#endif +#ifdef ELIBBAD + case ELIBBAD: return "ELIBBAD"; +#endif +#ifdef ELIBEXEC + case ELIBEXEC: return "ELIBEXEC"; +#endif +#ifdef ELIBMAX + case ELIBMAX: return "ELIBMAX"; +#endif +#ifdef ELIBSCN + case ELIBSCN: return "ELIBSCN"; +#endif +#ifdef ELNRNG + case ELNRNG: return "ELNRNG"; +#endif +#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) + case ELOOP: return "ELOOP"; +#endif +#ifdef EMFILE + case EMFILE: return "EMFILE"; +#endif +#ifdef EMLINK + case EMLINK: return "EMLINK"; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: return "EMSGSIZE"; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: return "EMULTIHOP"; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: return "ENAMETOOLONG"; +#endif +#ifdef ENAVAIL + case ENAVAIL: return "ENAVAIL"; +#endif +#ifdef ENET + case ENET: return "ENET"; +#endif +#ifdef ENETDOWN + case ENETDOWN: return "ENETDOWN"; +#endif +#ifdef ENETRESET + case ENETRESET: return "ENETRESET"; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: return "ENETUNREACH"; +#endif +#ifdef ENFILE + case ENFILE: return "ENFILE"; +#endif +#ifdef ENOANO + case ENOANO: return "ENOANO"; +#endif +#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) + case ENOBUFS: return "ENOBUFS"; +#endif +#ifdef ENOCSI + case ENOCSI: return "ENOCSI"; +#endif +#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) + case ENODATA: return "ENODATA"; +#endif +#ifdef ENODEV + case ENODEV: return "ENODEV"; +#endif +#ifdef ENOENT + case ENOENT: return "ENOENT"; +#endif +#ifdef ENOEXEC + case ENOEXEC: return "ENOEXEC"; +#endif +#ifdef ENOLCK + case ENOLCK: return "ENOLCK"; +#endif +#ifdef ENOLINK + case ENOLINK: return "ENOLINK"; +#endif +#ifdef ENOMEM + case ENOMEM: return "ENOMEM"; +#endif +#ifdef ENOMSG + case ENOMSG: return "ENOMSG"; +#endif +#ifdef ENONET + case ENONET: return "ENONET"; +#endif +#ifdef ENOPKG + case ENOPKG: return "ENOPKG"; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: return "ENOPROTOOPT"; +#endif +#ifdef ENOSPC + case ENOSPC: return "ENOSPC"; +#endif +#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) + case ENOSR: return "ENOSR"; +#endif +#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) + case ENOSTR: return "ENOSTR"; +#endif +#ifdef ENOSYM + case ENOSYM: return "ENOSYM"; +#endif +#ifdef ENOSYS + case ENOSYS: return "ENOSYS"; +#endif +#ifdef ENOTBLK + case ENOTBLK: return "ENOTBLK"; +#endif +#ifdef ENOTCONN + case ENOTCONN: return "ENOTCONN"; +#endif +#ifdef ENOTDIR + case ENOTDIR: return "ENOTDIR"; +#endif +#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) + case ENOTEMPTY: return "ENOTEMPTY"; +#endif +#ifdef ENOTNAM + case ENOTNAM: return "ENOTNAM"; +#endif +#ifdef ENOTSOCK + case ENOTSOCK: return "ENOTSOCK"; +#endif +#ifdef ENOTSUP + case ENOTSUP: return "ENOTSUP"; +#endif +#ifdef ENOTTY + case ENOTTY: return "ENOTTY"; +#endif +#ifdef ENOTUNIQ + case ENOTUNIQ: return "ENOTUNIQ"; +#endif +#ifdef ENXIO + case ENXIO: return "ENXIO"; +#endif +#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (EOPNOTSUPP != ENOTSUP)) + case EOPNOTSUPP: return "EOPNOTSUPP"; +#endif +#ifdef EPERM + case EPERM: return "EPERM"; +#endif +#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) + case EPFNOSUPPORT: return "EPFNOSUPPORT"; +#endif +#ifdef EPIPE + case EPIPE: return "EPIPE"; +#endif +#ifdef EPROCLIM + case EPROCLIM: return "EPROCLIM"; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: return "EPROCUNAVAIL"; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: return "EPROGMISMATCH"; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: return "EPROGUNAVAIL"; +#endif +#ifdef EPROTO + case EPROTO: return "EPROTO"; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: return "EPROTOTYPE"; +#endif +#ifdef ERANGE + case ERANGE: return "ERANGE"; +#endif +#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) + case EREFUSED: return "EREFUSED"; +#endif +#ifdef EREMCHG + case EREMCHG: return "EREMCHG"; +#endif +#ifdef EREMDEV + case EREMDEV: return "EREMDEV"; +#endif +#ifdef EREMOTE + case EREMOTE: return "EREMOTE"; +#endif +#ifdef EREMOTEIO + case EREMOTEIO: return "EREMOTEIO"; +#endif +#ifdef EREMOTERELEASE + case EREMOTERELEASE: return "EREMOTERELEASE"; +#endif +#ifdef EROFS + case EROFS: return "EROFS"; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: return "ERPCMISMATCH"; +#endif +#ifdef ERREMOTE + case ERREMOTE: return "ERREMOTE"; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: return "ESHUTDOWN"; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; +#endif +#ifdef ESPIPE + case ESPIPE: return "ESPIPE"; +#endif +#ifdef ESRCH + case ESRCH: return "ESRCH"; +#endif +#ifdef ESRMNT + case ESRMNT: return "ESRMNT"; +#endif +#ifdef ESTALE + case ESTALE: return "ESTALE"; +#endif +#ifdef ESUCCESS + case ESUCCESS: return "ESUCCESS"; +#endif +#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) + case ETIME: return "ETIME"; +#endif +#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) + case ETIMEDOUT: return "ETIMEDOUT"; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: return "ETOOMANYREFS"; +#endif +#ifdef ETXTBSY + case ETXTBSY: return "ETXTBSY"; +#endif +#ifdef EUCLEAN + case EUCLEAN: return "EUCLEAN"; +#endif +#ifdef EUNATCH + case EUNATCH: return "EUNATCH"; +#endif +#ifdef EUSERS + case EUSERS: return "EUSERS"; +#endif +#ifdef EVERSION + case EVERSION: return "EVERSION"; +#endif +#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) + case EWOULDBLOCK: return "EWOULDBLOCK"; +#endif +#ifdef EXDEV + case EXDEV: return "EXDEV"; +#endif +#ifdef EXFULL + case EXFULL: return "EXFULL"; +#endif + } + return "unknown error"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrnoMsg -- + * + * Return a human-readable message corresponding to a given + * errno value. + * + * Results: + * The return value is the standard POSIX error message for + * errno. This procedure is used instead of strerror because + * strerror returns slightly different values on different + * machines (e.g. different capitalizations), which cause + * problems for things such as regression tests. This procedure + * provides messages for most standard errors, then it calls + * strerror for things it doesn't understand. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ErrnoMsg(err) + int err; /* Error number (such as in errno variable). */ +{ + switch (err) { +#ifdef E2BIG + case E2BIG: return "argument list too long"; +#endif +#ifdef EACCES + case EACCES: return "permission denied"; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: return "address already in use"; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: return "can't assign requested address"; +#endif +#ifdef EADV + case EADV: return "advertise error"; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: return "address family not supported by protocol family"; +#endif +#ifdef EAGAIN + case EAGAIN: return "resource temporarily unavailable"; +#endif +#ifdef EALIGN + case EALIGN: return "EALIGN"; +#endif +#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) + case EALREADY: return "operation already in progress"; +#endif +#ifdef EBADE + case EBADE: return "bad exchange descriptor"; +#endif +#ifdef EBADF + case EBADF: return "bad file number"; +#endif +#ifdef EBADFD + case EBADFD: return "file descriptor in bad state"; +#endif +#ifdef EBADMSG + case EBADMSG: return "not a data message"; +#endif +#ifdef EBADR + case EBADR: return "bad request descriptor"; +#endif +#ifdef EBADRPC + case EBADRPC: return "RPC structure is bad"; +#endif +#ifdef EBADRQC + case EBADRQC: return "bad request code"; +#endif +#ifdef EBADSLT + case EBADSLT: return "invalid slot"; +#endif +#ifdef EBFONT + case EBFONT: return "bad font file format"; +#endif +#ifdef EBUSY + case EBUSY: return "file busy"; +#endif +#ifdef ECHILD + case ECHILD: return "no children"; +#endif +#ifdef ECHRNG + case ECHRNG: return "channel number out of range"; +#endif +#ifdef ECOMM + case ECOMM: return "communication error on send"; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: return "software caused connection abort"; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: return "connection refused"; +#endif +#ifdef ECONNRESET + case ECONNRESET: return "connection reset by peer"; +#endif +#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) + case EDEADLK: return "resource deadlock avoided"; +#endif +#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK)) + case EDEADLOCK: return "resource deadlock avoided"; +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: return "destination address required"; +#endif +#ifdef EDIRTY + case EDIRTY: return "mounting a dirty fs w/o force"; +#endif +#ifdef EDOM + case EDOM: return "math argument out of range"; +#endif +#ifdef EDOTDOT + case EDOTDOT: return "cross mount point"; +#endif +#ifdef EDQUOT + case EDQUOT: return "disk quota exceeded"; +#endif +#ifdef EDUPPKG + case EDUPPKG: return "duplicate package name"; +#endif +#ifdef EEXIST + case EEXIST: return "file already exists"; +#endif +#ifdef EFAULT + case EFAULT: return "bad address in system call argument"; +#endif +#ifdef EFBIG + case EFBIG: return "file too large"; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: return "host is down"; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: return "host is unreachable"; +#endif +#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) + case EIDRM: return "identifier removed"; +#endif +#ifdef EINIT + case EINIT: return "initialization error"; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: return "operation now in progress"; +#endif +#ifdef EINTR + case EINTR: return "interrupted system call"; +#endif +#ifdef EINVAL + case EINVAL: return "invalid argument"; +#endif +#ifdef EIO + case EIO: return "I/O error"; +#endif +#ifdef EISCONN + case EISCONN: return "socket is already connected"; +#endif +#ifdef EISDIR + case EISDIR: return "illegal operation on a directory"; +#endif +#ifdef EISNAME + case EISNAM: return "is a name file"; +#endif +#ifdef ELBIN + case ELBIN: return "ELBIN"; +#endif +#ifdef EL2HLT + case EL2HLT: return "level 2 halted"; +#endif +#ifdef EL2NSYNC + case EL2NSYNC: return "level 2 not synchronized"; +#endif +#ifdef EL3HLT + case EL3HLT: return "level 3 halted"; +#endif +#ifdef EL3RST + case EL3RST: return "level 3 reset"; +#endif +#ifdef ELIBACC + case ELIBACC: return "can not access a needed shared library"; +#endif +#ifdef ELIBBAD + case ELIBBAD: return "accessing a corrupted shared library"; +#endif +#ifdef ELIBEXEC + case ELIBEXEC: return "can not exec a shared library directly"; +#endif +#ifdef ELIBMAX + case ELIBMAX: return + "attempting to link in more shared libraries than system limit"; +#endif +#ifdef ELIBSCN + case ELIBSCN: return ".lib section in a.out corrupted"; +#endif +#ifdef ELNRNG + case ELNRNG: return "link number out of range"; +#endif +#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) + case ELOOP: return "too many levels of symbolic links"; +#endif +#ifdef EMFILE + case EMFILE: return "too many open files"; +#endif +#ifdef EMLINK + case EMLINK: return "too many links"; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: return "message too long"; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: return "multihop attempted"; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: return "file name too long"; +#endif +#ifdef ENAVAIL + case ENAVAIL: return "not available"; +#endif +#ifdef ENET + case ENET: return "ENET"; +#endif +#ifdef ENETDOWN + case ENETDOWN: return "network is down"; +#endif +#ifdef ENETRESET + case ENETRESET: return "network dropped connection on reset"; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: return "network is unreachable"; +#endif +#ifdef ENFILE + case ENFILE: return "file table overflow"; +#endif +#ifdef ENOANO + case ENOANO: return "anode table overflow"; +#endif +#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) + case ENOBUFS: return "no buffer space available"; +#endif +#ifdef ENOCSI + case ENOCSI: return "no CSI structure available"; +#endif +#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) + case ENODATA: return "no data available"; +#endif +#ifdef ENODEV + case ENODEV: return "no such device"; +#endif +#ifdef ENOENT + case ENOENT: return "no such file or directory"; +#endif +#ifdef ENOEXEC + case ENOEXEC: return "exec format error"; +#endif +#ifdef ENOLCK + case ENOLCK: return "no locks available"; +#endif +#ifdef ENOLINK + case ENOLINK: return "link has be severed"; +#endif +#ifdef ENOMEM + case ENOMEM: return "not enough memory"; +#endif +#ifdef ENOMSG + case ENOMSG: return "no message of desired type"; +#endif +#ifdef ENONET + case ENONET: return "machine is not on the network"; +#endif +#ifdef ENOPKG + case ENOPKG: return "package not installed"; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: return "bad proocol option"; +#endif +#ifdef ENOSPC + case ENOSPC: return "no space left on device"; +#endif +#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) + case ENOSR: return "out of stream resources"; +#endif +#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) + case ENOSTR: return "not a stream device"; +#endif +#ifdef ENOSYM + case ENOSYM: return "unresolved symbol name"; +#endif +#ifdef ENOSYS + case ENOSYS: return "function not implemented"; +#endif +#ifdef ENOTBLK + case ENOTBLK: return "block device required"; +#endif +#ifdef ENOTCONN + case ENOTCONN: return "socket is not connected"; +#endif +#ifdef ENOTDIR + case ENOTDIR: return "not a directory"; +#endif +#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) + case ENOTEMPTY: return "directory not empty"; +#endif +#ifdef ENOTNAM + case ENOTNAM: return "not a name file"; +#endif +#ifdef ENOTSOCK + case ENOTSOCK: return "socket operation on non-socket"; +#endif +#ifdef ENOTSUP + case ENOTSUP: return "operation not supported"; +#endif +#ifdef ENOTTY + case ENOTTY: return "inappropriate device for ioctl"; +#endif +#ifdef ENOTUNIQ + case ENOTUNIQ: return "name not unique on network"; +#endif +#ifdef ENXIO + case ENXIO: return "no such device or address"; +#endif +#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (EOPNOTSUPP != ENOTSUP)) + case EOPNOTSUPP: return "operation not supported on socket"; +#endif +#ifdef EPERM + case EPERM: return "not owner"; +#endif +#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) + case EPFNOSUPPORT: return "protocol family not supported"; +#endif +#ifdef EPIPE + case EPIPE: return "broken pipe"; +#endif +#ifdef EPROCLIM + case EPROCLIM: return "too many processes"; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: return "bad procedure for program"; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: return "program version wrong"; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: return "RPC program not available"; +#endif +#ifdef EPROTO + case EPROTO: return "protocol error"; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: return "protocol not suppored"; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: return "protocol wrong type for socket"; +#endif +#ifdef ERANGE + case ERANGE: return "math result unrepresentable"; +#endif +#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) + case EREFUSED: return "EREFUSED"; +#endif +#ifdef EREMCHG + case EREMCHG: return "remote address changed"; +#endif +#ifdef EREMDEV + case EREMDEV: return "remote device"; +#endif +#ifdef EREMOTE + case EREMOTE: return "pathname hit remote file system"; +#endif +#ifdef EREMOTEIO + case EREMOTEIO: return "remote i/o error"; +#endif +#ifdef EREMOTERELEASE + case EREMOTERELEASE: return "EREMOTERELEASE"; +#endif +#ifdef EROFS + case EROFS: return "read-only file system"; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: return "RPC version is wrong"; +#endif +#ifdef ERREMOTE + case ERREMOTE: return "object is remote"; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: return "can't send afer socket shutdown"; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: return "socket type not supported"; +#endif +#ifdef ESPIPE + case ESPIPE: return "invalid seek"; +#endif +#ifdef ESRCH + case ESRCH: return "no such process"; +#endif +#ifdef ESRMNT + case ESRMNT: return "srmount error"; +#endif +#ifdef ESTALE + case ESTALE: return "stale remote file handle"; +#endif +#ifdef ESUCCESS + case ESUCCESS: return "Error 0"; +#endif +#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) + case ETIME: return "timer expired"; +#endif +#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) + case ETIMEDOUT: return "connection timed out"; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: return "too many references: can't splice"; +#endif +#ifdef ETXTBSY + case ETXTBSY: return "text file or pseudo-device busy"; +#endif +#ifdef EUCLEAN + case EUCLEAN: return "structure needs cleaning"; +#endif +#ifdef EUNATCH + case EUNATCH: return "protocol driver not attached"; +#endif +#ifdef EUSERS + case EUSERS: return "too many users"; +#endif +#ifdef EVERSION + case EVERSION: return "version mismatch"; +#endif +#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) + case EWOULDBLOCK: return "operation would block"; +#endif +#ifdef EXDEV + case EXDEV: return "cross-domain link"; +#endif +#ifdef EXFULL + case EXFULL: return "message tables full"; +#endif + default: +#ifdef NO_STRERROR + return "unknown POSIX error"; +#else + return strerror(errno); +#endif + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SignalId -- + * + * Return a textual identifier for a signal number. + * + * Results: + * This procedure returns a machine-readable textual identifier + * that corresponds to sig. The identifier is the same as the + * #define name in signal.h. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SignalId(sig) + int sig; /* Number of signal. */ +{ + switch (sig) { +#ifdef SIGABRT + case SIGABRT: return "SIGABRT"; +#endif +#ifdef SIGALRM + case SIGALRM: return "SIGALRM"; +#endif +#ifdef SIGBUS + case SIGBUS: return "SIGBUS"; +#endif +#ifdef SIGCHLD + case SIGCHLD: return "SIGCHLD"; +#endif +#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) + case SIGCLD: return "SIGCLD"; +#endif +#ifdef SIGCONT + case SIGCONT: return "SIGCONT"; +#endif +#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) + case SIGEMT: return "SIGEMT"; +#endif +#ifdef SIGFPE + case SIGFPE: return "SIGFPE"; +#endif +#ifdef SIGHUP + case SIGHUP: return "SIGHUP"; +#endif +#ifdef SIGILL + case SIGILL: return "SIGILL"; +#endif +#ifdef SIGINT + case SIGINT: return "SIGINT"; +#endif +#ifdef SIGIO + case SIGIO: return "SIGIO"; +#endif +#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT)) + case SIGIOT: return "SIGIOT"; +#endif +#ifdef SIGKILL + case SIGKILL: return "SIGKILL"; +#endif +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO)) + case SIGLOST: return "SIGLOST"; +#endif +#ifdef SIGPIPE + case SIGPIPE: return "SIGPIPE"; +#endif +#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) + case SIGPOLL: return "SIGPOLL"; +#endif +#ifdef SIGPROF + case SIGPROF: return "SIGPROF"; +#endif +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) + case SIGPWR: return "SIGPWR"; +#endif +#ifdef SIGQUIT + case SIGQUIT: return "SIGQUIT"; +#endif +#ifdef SIGSEGV + case SIGSEGV: return "SIGSEGV"; +#endif +#ifdef SIGSTOP + case SIGSTOP: return "SIGSTOP"; +#endif +#ifdef SIGSYS + case SIGSYS: return "SIGSYS"; +#endif +#ifdef SIGTERM + case SIGTERM: return "SIGTERM"; +#endif +#ifdef SIGTRAP + case SIGTRAP: return "SIGTRAP"; +#endif +#ifdef SIGTSTP + case SIGTSTP: return "SIGTSTP"; +#endif +#ifdef SIGTTIN + case SIGTTIN: return "SIGTTIN"; +#endif +#ifdef SIGTTOU + case SIGTTOU: return "SIGTTOU"; +#endif +#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) + case SIGURG: return "SIGURG"; +#endif +#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) + case SIGUSR1: return "SIGUSR1"; +#endif +#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) + case SIGUSR2: return "SIGUSR2"; +#endif +#ifdef SIGVTALRM + case SIGVTALRM: return "SIGVTALRM"; +#endif +#ifdef SIGWINCH + case SIGWINCH: return "SIGWINCH"; +#endif +#ifdef SIGXCPU + case SIGXCPU: return "SIGXCPU"; +#endif +#ifdef SIGXFSZ + case SIGXFSZ: return "SIGXFSZ"; +#endif + } + return "unknown signal"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SignalMsg -- + * + * Return a human-readable message describing a signal. + * + * Results: + * This procedure returns a string describing sig that should + * make sense to a human. It may not be easy for a machine + * to parse. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SignalMsg(sig) + int sig; /* Number of signal. */ +{ + switch (sig) { +#ifdef SIGABRT + case SIGABRT: return "SIGABRT"; +#endif +#ifdef SIGALRM + case SIGALRM: return "alarm clock"; +#endif +#ifdef SIGBUS + case SIGBUS: return "bus error"; +#endif +#ifdef SIGCHLD + case SIGCHLD: return "child status changed"; +#endif +#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) + case SIGCLD: return "child status changed"; +#endif +#ifdef SIGCONT + case SIGCONT: return "continue after stop"; +#endif +#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) + case SIGEMT: return "EMT instruction"; +#endif +#ifdef SIGFPE + case SIGFPE: return "floating-point exception"; +#endif +#ifdef SIGHUP + case SIGHUP: return "hangup"; +#endif +#ifdef SIGILL + case SIGILL: return "illegal instruction"; +#endif +#ifdef SIGINT + case SIGINT: return "interrupt"; +#endif +#ifdef SIGIO + case SIGIO: return "input/output possible on file"; +#endif +#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT)) + case SIGIOT: return "IOT instruction"; +#endif +#ifdef SIGKILL + case SIGKILL: return "kill signal"; +#endif +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO)) + case SIGLOST: return "resource lost"; +#endif +#ifdef SIGPIPE + case SIGPIPE: return "write on pipe with no readers"; +#endif +#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) + case SIGPOLL: return "input/output possible on file"; +#endif +#ifdef SIGPROF + case SIGPROF: return "profiling alarm"; +#endif +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) + case SIGPWR: return "power-fail restart"; +#endif +#ifdef SIGQUIT + case SIGQUIT: return "quit signal"; +#endif +#ifdef SIGSEGV + case SIGSEGV: return "segmentation violation"; +#endif +#ifdef SIGSTOP + case SIGSTOP: return "stop"; +#endif +#ifdef SIGSYS + case SIGSYS: return "bad argument to system call"; +#endif +#ifdef SIGTERM + case SIGTERM: return "software termination signal"; +#endif +#ifdef SIGTRAP + case SIGTRAP: return "trace trap"; +#endif +#ifdef SIGTSTP + case SIGTSTP: return "stop signal from tty"; +#endif +#ifdef SIGTTIN + case SIGTTIN: return "background tty read"; +#endif +#ifdef SIGTTOU + case SIGTTOU: return "background tty write"; +#endif +#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) + case SIGURG: return "urgent I/O condition"; +#endif +#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) + case SIGUSR1: return "user-defined signal 1"; +#endif +#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) + case SIGUSR2: return "user-defined signal 2"; +#endif +#ifdef SIGVTALRM + case SIGVTALRM: return "virtual time alarm"; +#endif +#ifdef SIGWINCH + case SIGWINCH: return "window changed"; +#endif +#ifdef SIGXCPU + case SIGXCPU: return "exceeded CPU time limit"; +#endif +#ifdef SIGXFSZ + case SIGXFSZ: return "exceeded file size limit"; +#endif + } + return "unknown signal"; +} diff --git a/tcl/generic/tclPreserve.c b/tcl/generic/tclPreserve.c new file mode 100644 index 00000000000..0f813eb7b19 --- /dev/null +++ b/tcl/generic/tclPreserve.c @@ -0,0 +1,277 @@ +/* + * tclPreserve.c -- + * + * This file contains a collection of procedures that are used + * to make sure that widget records and other data structures + * aren't reallocated when there are nested procedures that + * depend on their existence. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * The following data structure is used to keep track of all the + * Tcl_Preserve calls that are still in effect. It grows as needed + * to accommodate any number of calls in effect. + */ + +typedef struct { + ClientData clientData; /* Address of preserved block. */ + int refCount; /* Number of Tcl_Preserve calls in effect + * for block. */ + int mustFree; /* Non-zero means Tcl_EventuallyFree was + * called while a Tcl_Preserve call was in + * effect, so the structure must be freed + * when refCount becomes zero. */ + Tcl_FreeProc *freeProc; /* Procedure to call to free. */ +} Reference; + +static Reference *refArray; /* First in array of references. */ +static int spaceAvl = 0; /* Total number of structures available + * at *firstRefPtr. */ +static int inUse = 0; /* Count of structures currently in use + * in refArray. */ +#define INITIAL_SIZE 2 + +/* + * Static routines in this file: + */ + +static void PreserveExitProc _ANSI_ARGS_((ClientData clientData)); + + +/* + *---------------------------------------------------------------------- + * + * PreserveExitProc -- + * + * Called during exit processing to clean up the reference array. + * + * Results: + * None. + * + * Side effects: + * Frees the storage of the reference array. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PreserveExitProc(clientData) + ClientData clientData; /* NULL -Unused. */ +{ + if (spaceAvl != 0) { + ckfree((char *) refArray); + refArray = (Reference *) NULL; + inUse = 0; + spaceAvl = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Preserve -- + * + * This procedure is used by a procedure to declare its interest + * in a particular block of memory, so that the block will not be + * reallocated until a matching call to Tcl_Release has been made. + * + * Results: + * None. + * + * Side effects: + * Information is retained so that the block of memory will + * not be freed until at least the matching call to Tcl_Release. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Preserve(clientData) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ +{ + Reference *refPtr; + int i; + + /* + * See if there is already a reference for this pointer. If so, + * just increment its reference count. + */ + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData == clientData) { + refPtr->refCount++; + return; + } + } + + /* + * Make a reference array if it doesn't already exist, or make it + * bigger if it is full. + */ + + if (inUse == spaceAvl) { + if (spaceAvl == 0) { + Tcl_CreateExitHandler((Tcl_ExitProc *) PreserveExitProc, + (ClientData) NULL); + refArray = (Reference *) ckalloc((unsigned) + (INITIAL_SIZE*sizeof(Reference))); + spaceAvl = INITIAL_SIZE; + } else { + Reference *new; + + new = (Reference *) ckalloc((unsigned) + (2*spaceAvl*sizeof(Reference))); + memcpy((VOID *) new, (VOID *) refArray, + spaceAvl*sizeof(Reference)); + ckfree((char *) refArray); + refArray = new; + spaceAvl *= 2; + } + } + + /* + * Make a new entry for the new reference. + */ + + refPtr = &refArray[inUse]; + refPtr->clientData = clientData; + refPtr->refCount = 1; + refPtr->mustFree = 0; + refPtr->freeProc = TCL_STATIC; + inUse += 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Release -- + * + * This procedure is called to cancel a previous call to + * Tcl_Preserve, thereby allowing a block of memory to be + * freed (if no one else cares about it). + * + * Results: + * None. + * + * Side effects: + * If Tcl_EventuallyFree has been called for clientData, and if + * no other call to Tcl_Preserve is still in effect, the block of + * memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Release(clientData) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ +{ + Reference *refPtr; + int mustFree; + Tcl_FreeProc *freeProc; + int i; + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData != clientData) { + continue; + } + refPtr->refCount--; + if (refPtr->refCount == 0) { + + /* + * Must remove information from the slot before calling freeProc + * to avoid reentrancy problems if the freeProc calls Tcl_Preserve + * on the same clientData. Copy down the last reference in the + * array to overwrite the current slot. + */ + + freeProc = refPtr->freeProc; + mustFree = refPtr->mustFree; + inUse--; + if (i < inUse) { + refArray[i] = refArray[inUse]; + } + if (mustFree) { + if ((freeProc == TCL_DYNAMIC) || + (freeProc == (Tcl_FreeProc *) free)) { + ckfree((char *) clientData); + } else { + (*freeProc)((char *) clientData); + } + } + } + return; + } + + /* + * Reference not found. This is a bug in the caller. + */ + + panic("Tcl_Release couldn't find reference for 0x%x", clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EventuallyFree -- + * + * Free up a block of memory, unless a call to Tcl_Preserve is in + * effect for that block. In this case, defer the free until all + * calls to Tcl_Preserve have been undone by matching calls to + * Tcl_Release. + * + * Results: + * None. + * + * Side effects: + * Ptr may be released by calling free(). + * + *---------------------------------------------------------------------- + */ + +void +Tcl_EventuallyFree(clientData, freeProc) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ + Tcl_FreeProc *freeProc; /* Procedure to actually do free. */ +{ + Reference *refPtr; + int i; + + /* + * See if there is a reference for this pointer. If so, set its + * "mustFree" flag (the flag had better not be set already!). + */ + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData != clientData) { + continue; + } + if (refPtr->mustFree) { + panic("Tcl_EventuallyFree called twice for 0x%x\n", clientData); + } + refPtr->mustFree = 1; + refPtr->freeProc = freeProc; + return; + } + + /* + * No reference for this block. Free it now. + */ + + if ((freeProc == TCL_DYNAMIC) + || (freeProc == (Tcl_FreeProc *) free)) { + ckfree((char *) clientData); + } else { + (*freeProc)((char *)clientData); + } +} diff --git a/tcl/generic/tclProc.c b/tcl/generic/tclProc.c new file mode 100644 index 00000000000..b956c9670fc --- /dev/null +++ b/tcl/generic/tclProc.c @@ -0,0 +1,1528 @@ +/* + * tclProc.c -- + * + * This file contains routines that implement Tcl procedures, + * including the "proc" and "uplevel" commands. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclCompile.h" + +/* + * Prototypes for static functions in this file + */ + +static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr)); +static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr)); + +/* + * The ProcBodyObjType type + */ + +Tcl_ObjType tclProcBodyType = { + "procbody", /* name for this type */ + ProcBodyFree, /* FreeInternalRep procedure */ + ProcBodyDup, /* DupInternalRep procedure */ + ProcBodyUpdateString, /* UpdateString procedure */ + ProcBodySetFromAny /* SetFromAny procedure */ +}; + + +/* + *---------------------------------------------------------------------- + * + * Tcl_ProcObjCmd -- + * + * This object-based procedure is invoked to process the "proc" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * A new procedure gets created. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ProcObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + Proc *procPtr; + char *fullName, *procName; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr; + Tcl_Command cmd; + Tcl_DString ds; + int result; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name args body"); + return TCL_ERROR; + } + + /* + * Determine the namespace where the procedure should reside. Unless + * the command name includes namespace qualifiers, this will be the + * current namespace. + */ + + fullName = Tcl_GetStringFromObj(objv[1], (int *) NULL); + result = TclGetNamespaceForQualName(interp, fullName, + (Namespace *) NULL, TCL_LEAVE_ERR_MSG, + &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + if (result != TCL_OK) { + return result; + } + if (nsPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't create procedure \"", fullName, + "\": unknown namespace", (char *) NULL); + return TCL_ERROR; + } + if (procName == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't create procedure \"", fullName, + "\": bad procedure name", (char *) NULL); + return TCL_ERROR; + } + if ((nsPtr != iPtr->globalNsPtr) + && (procName != NULL) && (procName[0] == ':')) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't create procedure \"", procName, + "\" in non-global namespace with name starting with \":\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Create the data structure to represent the procedure. + */ + if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], + &procPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Now create a command for the procedure. This will initially be in + * the current namespace unless the procedure's name included namespace + * qualifiers. To create the new command in the right namespace, we + * generate a fully qualified name for it. + */ + + Tcl_DStringInit(&ds); + if (nsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + Tcl_DStringAppend(&ds, "::", 2); + } + Tcl_DStringAppend(&ds, procName, -1); + + Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc, + (ClientData) procPtr, TclProcDeleteProc); + cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); + + /* + * Now initialize the new procedure's cmdPtr field. This will be used + * later when the procedure is called to determine what namespace the + * procedure will run in. This will be different than the current + * namespace if the proc was renamed into a different namespace. + */ + + procPtr->cmdPtr = (Command *) cmd; + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclCreateProc -- + * + * Creates the data associated with a Tcl procedure definition. + * This procedure knows how to handle two types of body objects: + * strings and procbody. Strings are the traditional (and common) value + * for bodies, procbody are values created by extensions that have + * loaded a previously compiled script. + * + * Results: + * Returns TCL_OK on success, along with a pointer to a Tcl + * procedure definition in procPtrPtr. This definition should + * be freed by calling TclCleanupProc() when it is no longer + * needed. Returns TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) + Tcl_Interp *interp; /* interpreter containing proc */ + Namespace *nsPtr; /* namespace containing this proc */ + char *procName; /* unqualified name of this proc */ + Tcl_Obj *argsPtr; /* description of arguments */ + Tcl_Obj *bodyPtr; /* command body */ + Proc **procPtrPtr; /* returns: pointer to proc data */ +{ + Interp *iPtr = (Interp*)interp; + char **argArray = NULL; + + register Proc *procPtr; + int i, length, result, numArgs; + char *args, *bytes, *p; + register CompiledLocal *localPtr; + Tcl_Obj *defPtr; + int precompiled = 0; + + if (bodyPtr->typePtr == &tclProcBodyType) { + /* + * Because the body is a TclProProcBody, the actual body is already + * compiled, and it is not shared with anyone else, so it's OK not to + * unshare it (as a matter of fact, it is bad to unshare it, because + * there may be no source code). + * + * We don't create and initialize a Proc structure for the procedure; + * rather, we use what is in the body object. Note that + * we initialize its cmdPtr field below after we've created the command + * for the procedure. We increment the ref count of the Proc struct + * since the command (soon to be created) will be holding a reference + * to it. + */ + + procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr; + procPtr->iPtr = iPtr; + procPtr->refCount++; + precompiled = 1; + } else { + /* + * If the procedure's body object is shared because its string value is + * identical to, e.g., the body of another procedure, we must create a + * private copy for this procedure to use. Such sharing of procedure + * bodies is rare but can cause problems. A procedure body is compiled + * in a context that includes the number of compiler-allocated "slots" + * for local variables. Each formal parameter is given a local variable + * slot (the "procPtr->numCompiledLocals = numArgs" assignment + * below). This means that the same code can not be shared by two + * procedures that have a different number of arguments, even if their + * bodies are identical. Note that we don't use Tcl_DuplicateObj since + * we would not want any bytecode internal representation. + */ + + if (Tcl_IsShared(bodyPtr)) { + bytes = Tcl_GetStringFromObj(bodyPtr, &length); + bodyPtr = Tcl_NewStringObj(bytes, length); + } + + /* + * Create and initialize a Proc structure for the procedure. Note that + * we initialize its cmdPtr field below after we've created the command + * for the procedure. We increment the ref count of the procedure's + * body object since there will be a reference to it in the Proc + * structure. + */ + + Tcl_IncrRefCount(bodyPtr); + + procPtr = (Proc *) ckalloc(sizeof(Proc)); + procPtr->iPtr = iPtr; + procPtr->refCount = 1; + procPtr->bodyPtr = bodyPtr; + procPtr->numArgs = 0; /* actual argument count is set below. */ + procPtr->numCompiledLocals = 0; + procPtr->firstLocalPtr = NULL; + procPtr->lastLocalPtr = NULL; + } + + /* + * Break up the argument list into argument specifiers, then process + * each argument specifier. + * If the body is precompiled, processing is limited to checking that + * the the parsed argument is consistent with the one stored in the + * Proc. + * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS. + */ + + args = Tcl_GetStringFromObj(argsPtr, &length); + result = Tcl_SplitList(interp, args, &numArgs, &argArray); + if (result != TCL_OK) { + goto procError; + } + + if (precompiled) { + if (numArgs > procPtr->numArgs) { + char buf[128]; + sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d", + numArgs, procPtr->numArgs); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + buf, (char *) NULL); + goto procError; + } + localPtr = procPtr->firstLocalPtr; + } else { + procPtr->numArgs = numArgs; + procPtr->numCompiledLocals = numArgs; + } + for (i = 0; i < numArgs; i++) { + int fieldCount, nameLength, valueLength; + char **fieldValues; + + /* + * Now divide the specifier up into name and default. + */ + + result = Tcl_SplitList(interp, argArray[i], &fieldCount, + &fieldValues); + if (result != TCL_OK) { + goto procError; + } + if (fieldCount > 2) { + ckfree((char *) fieldValues); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "too many fields in argument specifier \"", + argArray[i], "\"", (char *) NULL); + goto procError; + } + if ((fieldCount == 0) || (*fieldValues[0] == 0)) { + ckfree((char *) fieldValues); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + "\" has argument with no name", (char *) NULL); + goto procError; + } + + nameLength = strlen(fieldValues[0]); + if (fieldCount == 2) { + valueLength = strlen(fieldValues[1]); + } else { + valueLength = 0; + } + + /* + * Check that the formal parameter name is a scalar. + */ + + p = fieldValues[0]; + while (*p != '\0') { + if (*p == '(') { + char *q = p; + do { + q++; + } while (*q != '\0'); + q--; + if (*q == ')') { /* we have an array element */ + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + "\" has formal parameter \"", fieldValues[0], + "\" that is an array element", + (char *) NULL); + ckfree((char *) fieldValues); + goto procError; + } + } + p++; + } + + if (precompiled) { + /* + * compare the parsed argument with the stored one + */ + + if ((localPtr->nameLength != nameLength) + || (strcmp(localPtr->name, fieldValues[0])) + || (localPtr->frameIndex != i) + || (localPtr->flags != (VAR_SCALAR | VAR_ARGUMENT)) + || ((localPtr->defValuePtr == NULL) + && (fieldCount == 2)) + || ((localPtr->defValuePtr != NULL) + && (fieldCount != 2))) { + char buf[128]; + sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body", + i); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + buf, (char *) NULL); + ckfree((char *) fieldValues); + goto procError; + } + + /* + * compare the default value if any + */ + + if (localPtr->defValuePtr != NULL) { + int tmpLength; + char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, + &tmpLength); + if ((valueLength != tmpLength) + || (strncmp(fieldValues[1], tmpPtr, + (size_t) tmpLength))) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + "\": formal parameter \"", + fieldValues[0], + "\" has default value inconsistent with precompiled body", + (char *) NULL); + ckfree((char *) fieldValues); + goto procError; + } + } + + localPtr = localPtr->nextPtr; + } else { + /* + * Allocate an entry in the runtime procedure frame's array of + * local variables for the argument. + */ + + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameLength+1)); + if (procPtr->firstLocalPtr == NULL) { + procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; + } else { + procPtr->lastLocalPtr->nextPtr = localPtr; + procPtr->lastLocalPtr = localPtr; + } + localPtr->nextPtr = NULL; + localPtr->nameLength = nameLength; + localPtr->frameIndex = i; + localPtr->flags = VAR_SCALAR | VAR_ARGUMENT; + localPtr->resolveInfo = NULL; + + if (fieldCount == 2) { + localPtr->defValuePtr = + Tcl_NewStringObj(fieldValues[1], valueLength); + Tcl_IncrRefCount(localPtr->defValuePtr); + } else { + localPtr->defValuePtr = NULL; + } + strcpy(localPtr->name, fieldValues[0]); + } + + ckfree((char *) fieldValues); + } + + /* + * Now initialize the new procedure's cmdPtr field. This will be used + * later when the procedure is called to determine what namespace the + * procedure will run in. This will be different than the current + * namespace if the proc was renamed into a different namespace. + */ + + *procPtrPtr = procPtr; + ckfree((char *) argArray); + return TCL_OK; + +procError: + if (precompiled) { + procPtr->refCount--; + } else { + Tcl_DecrRefCount(bodyPtr); + while (procPtr->firstLocalPtr != NULL) { + localPtr = procPtr->firstLocalPtr; + procPtr->firstLocalPtr = localPtr->nextPtr; + + defPtr = localPtr->defValuePtr; + if (defPtr != NULL) { + Tcl_DecrRefCount(defPtr); + } + + ckfree((char *) localPtr); + } + ckfree((char *) procPtr); + } + if (argArray != NULL) { + ckfree((char *) argArray); + } + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * TclGetFrame -- + * + * Given a description of a procedure frame, such as the first + * argument to an "uplevel" or "upvar" command, locate the + * call frame for the appropriate level of procedure. + * + * Results: + * The return value is -1 if an error occurred in finding the + * frame (in this case an error message is left in interp->result). + * 1 is returned if string was either a number or a number preceded + * by "#" and it specified a valid frame. 0 is returned if string + * isn't one of the two things above (in this case, the lookup + * acts as if string were "1"). The variable pointed to by + * framePtrPtr is filled in with the address of the desired frame + * (unless an error occurs, in which case it isn't modified). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetFrame(interp, string, framePtrPtr) + Tcl_Interp *interp; /* Interpreter in which to find frame. */ + char *string; /* String describing frame. */ + CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL + * if global frame indicated). */ +{ + register Interp *iPtr = (Interp *) interp; + int curLevel, level, result; + CallFrame *framePtr; + + /* + * Parse string to figure out which level number to go to. + */ + + result = 1; + curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; + if (*string == '#') { + if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) { + return -1; + } + if (level < 0) { + levelError: + Tcl_AppendResult(interp, "bad level \"", string, "\"", + (char *) NULL); + return -1; + } + } else if (isdigit(UCHAR(*string))) { + if (Tcl_GetInt(interp, string, &level) != TCL_OK) { + return -1; + } + level = curLevel - level; + } else { + level = curLevel - 1; + result = 0; + } + + /* + * Figure out which frame to use, and modify the interpreter so + * its variables come from that frame. + */ + + if (level == 0) { + framePtr = NULL; + } else { + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + } + *framePtrPtr = framePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UplevelObjCmd -- + * + * This object procedure is invoked to process the "uplevel" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UplevelObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + char *optLevel; + int length, result; + CallFrame *savedVarFramePtr, *framePtr; + + if (objc < 2) { + uplevelSyntax: + Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); + return TCL_ERROR; + } + + /* + * Find the level to use for executing the command. + * THIS FAILS IF THE OBJECT RESULT'S STRING REP CONTAINS A NULL. + */ + + optLevel = Tcl_GetStringFromObj(objv[1], &length); + result = TclGetFrame(interp, optLevel, &framePtr); + if (result == -1) { + return TCL_ERROR; + } + objc -= (result+1); + if (objc == 0) { + goto uplevelSyntax; + } + objv += (result+1); + + /* + * Modify the interpreter state to execute in the given frame. + */ + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + + /* + * Execute the residual arguments as a command. + */ + + if (objc == 1) { + result = Tcl_EvalObj(interp, objv[0]); + } else { + Tcl_Obj *cmdObjPtr = Tcl_ConcatObj(objc, objv); + result = Tcl_EvalObj(interp, cmdObjPtr); + Tcl_DecrRefCount(cmdObjPtr); /* done with object */ + } + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + + /* + * Restore the variable frame, and return. + */ + + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclFindProc -- + * + * Given the name of a procedure, return a pointer to the + * record describing the procedure. + * + * Results: + * NULL is returned if the name doesn't correspond to any + * procedure. Otherwise the return value is a pointer to + * the procedure's record. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Proc * +TclFindProc(iPtr, procName) + Interp *iPtr; /* Interpreter in which to look. */ + char *procName; /* Name of desired procedure. */ +{ + Tcl_Command cmd; + Tcl_Command origCmd; + Command *cmdPtr; + + cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, + (Tcl_Namespace *) NULL, /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { + return NULL; + } + cmdPtr = (Command *) cmd; + + origCmd = TclGetOriginalCommand(cmd); + if (origCmd != NULL) { + cmdPtr = (Command *) origCmd; + } + if (cmdPtr->proc != TclProcInterpProc) { + return NULL; + } + return (Proc *) cmdPtr->clientData; +} + +/* + *---------------------------------------------------------------------- + * + * TclIsProc -- + * + * Tells whether a command is a Tcl procedure or not. + * + * Results: + * If the given command is actually a Tcl procedure, the + * return value is the address of the record describing + * the procedure. Otherwise the return value is 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Proc * +TclIsProc(cmdPtr) + Command *cmdPtr; /* Command to test. */ +{ + Tcl_Command origCmd; + + origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (origCmd != NULL) { + cmdPtr = (Command *) origCmd; + } + if (cmdPtr->proc == TclProcInterpProc) { + return (Proc *) cmdPtr->clientData; + } + return (Proc *) 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclProcInterpProc -- + * + * When a Tcl procedure gets invoked with an argc/argv array of + * strings, this routine gets invoked to interpret the procedure. + * + * Results: + * A standard Tcl result value, usually TCL_OK. + * + * Side effects: + * Depends on the commands in the procedure. + * + *---------------------------------------------------------------------- + */ + +int +TclProcInterpProc(clientData, interp, argc, argv) + ClientData clientData; /* Record describing procedure to be + * interpreted. */ + Tcl_Interp *interp; /* Interpreter in which procedure was + * invoked. */ + int argc; /* Count of number of arguments to this + * procedure. */ + register char **argv; /* Argument values. */ +{ + register Tcl_Obj *objPtr; + register int i; + int result; + + /* + * This procedure generates an objv array for object arguments that hold + * the argv strings. It starts out with stack-allocated space but uses + * dynamically-allocated storage if needed. + */ + +#define NUM_ARGS 20 + Tcl_Obj *(objStorage[NUM_ARGS]); + register Tcl_Obj **objv = objStorage; + + /* + * Create the object argument array "objv". Make sure objv is large + * enough to hold the objc arguments plus 1 extra for the zero + * end-of-objv word. + */ + + if ((argc + 1) > NUM_ARGS) { + objv = (Tcl_Obj **) + ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); + } + + for (i = 0; i < argc; i++) { + objv[i] = Tcl_NewStringObj(argv[i], -1); + Tcl_IncrRefCount(objv[i]); + } + objv[argc] = 0; + + /* + * Use TclObjInterpProc to actually interpret the procedure. + */ + + result = TclObjInterpProc(clientData, interp, argc, objv); + + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + + /* + * Decrement the ref counts on the objv elements since we are done + * with them. + */ + + for (i = 0; i < argc; i++) { + objPtr = objv[i]; + TclDecrRefCount(objPtr); + } + + /* + * Free the objv array if malloc'ed storage was used. + */ + + if (objv != objStorage) { + ckfree((char *) objv); + } + return result; +#undef NUM_ARGS +} + +/* + *---------------------------------------------------------------------- + * + * TclObjInterpProc -- + * + * When a Tcl procedure gets invoked during bytecode evaluation, this + * object-based routine gets invoked to interpret the procedure. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * Depends on the commands in the procedure. + * + *---------------------------------------------------------------------- + */ + +int +TclObjInterpProc(clientData, interp, objc, objv) + ClientData clientData; /* Record describing procedure to be + * interpreted. */ + Tcl_Interp *interp; /* Interpreter in which procedure was + * invoked. */ + int objc; /* Count of number of arguments to this + * procedure. */ + Tcl_Obj *CONST objv[]; /* Argument value objects. */ +{ + Interp *iPtr = (Interp *) interp; + Proc *procPtr = (Proc *) clientData; + Namespace *nsPtr = procPtr->cmdPtr->nsPtr; + CallFrame frame; + register CallFrame *framePtr = &frame; + register CompiledLocal *localPtr; + char *procName, *bytes; + int nameLen, localCt, numArgs, argCt, length, i, result; + Var *varPtr; + + /* + * This procedure generates an array "compiledLocals" that holds the + * storage for local variables. It starts out with stack-allocated space + * but uses dynamically-allocated storage if needed. + */ + +#define NUM_LOCALS 20 + Var localStorage[NUM_LOCALS]; + Var *compiledLocals = localStorage; + + /* + * Get the procedure's name. + * THIS FAILS IF THE PROC NAME'S STRING REP HAS A NULL. + */ + + procName = Tcl_GetStringFromObj(objv[0], &nameLen); + + /* + * If necessary, compile the procedure's body. The compiler will + * allocate frame slots for the procedure's non-argument local + * variables. Note that compiling the body might increase + * procPtr->numCompiledLocals if new local variables are found + * while compiling. + */ + + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, + "body of proc", procName); + + if (result != TCL_OK) { + return result; + } + + /* + * Create the "compiledLocals" array. Make sure it is large enough to + * hold all the procedure's compiled local variables, including its + * formal parameters. + */ + + localCt = procPtr->numCompiledLocals; + if (localCt > NUM_LOCALS) { + compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var)); + } + + /* + * Set up and push a new call frame for the new procedure invocation. + * This call frame will execute in the proc's namespace, which might + * be different than the current namespace. The proc's namespace is + * that of its command, which can change if the command is renamed + * from one namespace to another. + */ + + result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1); + + if (result != TCL_OK) { + return result; + } + + framePtr->objc = objc; + framePtr->objv = objv; /* ref counts for args are incremented below */ + + /* + * Initialize and resolve compiled variable references. + */ + + framePtr->procPtr = procPtr; + framePtr->numCompiledLocals = localCt; + framePtr->compiledLocals = compiledLocals; + + TclInitCompiledLocals(interp, framePtr, nsPtr); + + /* + * Match and assign the call's actual parameters to the procedure's + * formal arguments. The formal arguments are described by the first + * numArgs entries in both the Proc structure's local variable list and + * the call frame's local variable array. + */ + + numArgs = procPtr->numArgs; + varPtr = framePtr->compiledLocals; + localPtr = procPtr->firstLocalPtr; + argCt = objc; + for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) { + if (!TclIsVarArgument(localPtr)) { + panic("TclObjInterpProc: local variable %s is not argument but should be", + localPtr->name); + return TCL_ERROR; + } + if (TclIsVarTemporary(localPtr)) { + panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i); + return TCL_ERROR; + } + + /* + * Handle the special case of the last formal being "args". When + * it occurs, assign it a list consisting of all the remaining + * actual arguments. + */ + + if ((i == numArgs) && ((localPtr->name[0] == 'a') + && (strcmp(localPtr->name, "args") == 0))) { + Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i])); + varPtr->value.objPtr = listPtr; + Tcl_IncrRefCount(listPtr); /* local var is a reference */ + varPtr->flags &= ~VAR_UNDEFINED; + argCt = 0; + break; /* done processing args */ + } else if (argCt > 0) { + Tcl_Obj *objPtr = objv[i]; + varPtr->value.objPtr = objPtr; + varPtr->flags &= ~VAR_UNDEFINED; + Tcl_IncrRefCount(objPtr); /* since the local variable now has + * another reference to object. */ + } else if (localPtr->defValuePtr != NULL) { + Tcl_Obj *objPtr = localPtr->defValuePtr; + varPtr->value.objPtr = objPtr; + varPtr->flags &= ~VAR_UNDEFINED; + Tcl_IncrRefCount(objPtr); /* since the local variable now has + * another reference to object. */ + } else { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "no value given for parameter \"", localPtr->name, + "\" to \"", Tcl_GetStringFromObj(objv[0], (int *) NULL), + "\"", (char *) NULL); + result = TCL_ERROR; + goto procDone; + } + varPtr++; + localPtr = localPtr->nextPtr; + } + if (argCt > 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "called \"", Tcl_GetStringFromObj(objv[0], (int *) NULL), + "\" with too many arguments", (char *) NULL); + result = TCL_ERROR; + goto procDone; + } + + /* + * Invoke the commands in the procedure's body. + */ + + if (tclTraceExec >= 1) { + fprintf(stdout, "Calling proc "); + for (i = 0; i < objc; i++) { + bytes = Tcl_GetStringFromObj(objv[i], &length); + TclPrintSource(stdout, bytes, TclMin(length, 15)); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } + + iPtr->returnCode = TCL_OK; + procPtr->refCount++; + result = Tcl_EvalObj(interp, procPtr->bodyPtr); + procPtr->refCount--; + if (procPtr->refCount <= 0) { + TclProcCleanupProc(procPtr); + } + + if (result != TCL_OK) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } else if (result == TCL_ERROR) { + char msg[100]; + sprintf(msg, "\n (procedure \"%.50s\" line %d)", + procName, iPtr->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } else if (result == TCL_BREAK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"break\" outside of a loop", -1); + result = TCL_ERROR; + } else if (result == TCL_CONTINUE) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"continue\" outside of a loop", -1); + result = TCL_ERROR; + } + } + + procDone: + + /* + * Pop and free the call frame for this procedure invocation. + */ + + Tcl_PopCallFrame(interp); + + /* + * Free the compiledLocals array if malloc'ed storage was used. + */ + + if (compiledLocals != localStorage) { + ckfree((char *) compiledLocals); + } + return result; +#undef NUM_LOCALS +} + +/* + *---------------------------------------------------------------------- + * + * TclProcCompileProc -- + * + * Called just before a procedure is executed to compile the + * body to byte codes. If the type of the body is not + * "byte code" or if the compile conditions have changed + * (namespace context, epoch counters, etc.) then the body + * is recompiled. Otherwise, this procedure does nothing. + * + * Results: + * None. + * + * Side effects: + * May change the internal representation of the body object + * to compiled code. + * + *---------------------------------------------------------------------- + */ + +int +TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) + Tcl_Interp *interp; /* Interpreter containing procedure. */ + Proc *procPtr; /* Data associated with procedure. */ + Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr, + * but could be any code fragment compiled + * in the context of this procedure.) */ + Namespace *nsPtr; /* Namespace containing procedure. */ + CONST char *description; /* string describing this body of code. */ + CONST char *procName; /* Name of this procedure. */ +{ + Interp *iPtr = (Interp*)interp; + int result; + Tcl_CallFrame frame; + Proc *saveProcPtr; + ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + + /* + * If necessary, compile the procedure's body. The compiler will + * allocate frame slots for the procedure's non-argument local + * variables. If the ByteCode already exists, make sure it hasn't been + * invalidated by someone redefining a core command (this might make the + * compiled code wrong). Also, if the code was compiled in/for a + * different interpreter, we recompile it. Note that compiling the body + * might increase procPtr->numCompiledLocals if new local variables are + * found while compiling. + * + * Precompiled procedure bodies, however, are immutable and therefore + * they are not recompiled, even if things have changed. + */ + + if (bodyPtr->typePtr == &tclByteCodeType) { + if ((codePtr->iPtr != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != nsPtr)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if (codePtr->iPtr != iPtr) { + Tcl_AppendResult(interp, + "a precompiled script jumped interps", NULL); + return TCL_ERROR; + } + codePtr->compileEpoch = iPtr->compileEpoch; + codePtr->nsPtr = nsPtr; + } else { + tclByteCodeType.freeIntRepProc(bodyPtr); + bodyPtr->typePtr = (Tcl_ObjType *) NULL; + } + } + } + if (bodyPtr->typePtr != &tclByteCodeType) { + char buf[100]; + int numChars; + char *ellipsis; + + if (tclTraceCompile >= 1) { + /* + * Display a line summarizing the top level command we + * are about to compile. + */ + + numChars = strlen(procName); + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + fprintf(stdout, "Compiling %s \"%.*s%s\"\n", + description, numChars, procName, ellipsis); + } + + /* + * Plug the current procPtr into the interpreter and coerce + * the code body to byte codes. The interpreter needs to + * know which proc it's compiling so that it can access its + * list of compiled locals. + * + * TRICKY NOTE: Be careful to push a call frame with the + * proper namespace context, so that the byte codes are + * compiled in the appropriate class context. + */ + + saveProcPtr = iPtr->compiledProcPtr; + iPtr->compiledProcPtr = procPtr; + + result = Tcl_PushCallFrame(interp, &frame, + (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); + + if (result == TCL_OK) { + result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); + Tcl_PopCallFrame(interp); + } + + iPtr->compiledProcPtr = saveProcPtr; + + if (result != TCL_OK) { + if (result == TCL_ERROR) { + numChars = strlen(procName); + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)", + description, numChars, procName, ellipsis, + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buf, -1); + } + return result; + } + } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { + register CompiledLocal *localPtr; + + /* + * The resolver epoch has changed, but we only need to invalidate + * the resolver cache. + */ + + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + localPtr->flags &= ~(VAR_RESOLVED); + if (localPtr->resolveInfo) { + if (localPtr->resolveInfo->deleteProc) { + localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); + } else { + ckfree((char*)localPtr->resolveInfo); + } + localPtr->resolveInfo = NULL; + } + } + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclProcDeleteProc -- + * + * This procedure is invoked just before a command procedure is + * removed from an interpreter. Its job is to release all the + * resources allocated to the procedure. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed, unless the procedure is actively being + * executed. In this case the cleanup is delayed until the + * last call to the current procedure completes. + * + *---------------------------------------------------------------------- + */ + +void +TclProcDeleteProc(clientData) + ClientData clientData; /* Procedure to be deleted. */ +{ + Proc *procPtr = (Proc *) clientData; + + procPtr->refCount--; + if (procPtr->refCount <= 0) { + TclProcCleanupProc(procPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclProcCleanupProc -- + * + * This procedure does all the real work of freeing up a Proc + * structure. It's called only when the structure's reference + * count becomes zero. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed. + * + *---------------------------------------------------------------------- + */ + +void +TclProcCleanupProc(procPtr) + register Proc *procPtr; /* Procedure to be deleted. */ +{ + register CompiledLocal *localPtr; + Tcl_Obj *bodyPtr = procPtr->bodyPtr; + Tcl_Obj *defPtr; + Tcl_ResolvedVarInfo *resVarInfo; + + if (bodyPtr != NULL) { + Tcl_DecrRefCount(bodyPtr); + } + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { + CompiledLocal *nextPtr = localPtr->nextPtr; + + resVarInfo = localPtr->resolveInfo; + if (resVarInfo) { + if (resVarInfo->deleteProc) { + (*resVarInfo->deleteProc)(resVarInfo); + } else { + ckfree((char *) resVarInfo); + } + } + + if (localPtr->defValuePtr != NULL) { + defPtr = localPtr->defValuePtr; + Tcl_DecrRefCount(defPtr); + } + ckfree((char *) localPtr); + localPtr = nextPtr; + } + ckfree((char *) procPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclUpdateReturnInfo -- + * + * This procedure is called when procedures return, and at other + * points where the TCL_RETURN code is used. It examines fields + * such as iPtr->returnCode and iPtr->errorCode and modifies + * the real return status accordingly. + * + * Results: + * The return value is the true completion code to use for + * the procedure, instead of TCL_RETURN. + * + * Side effects: + * The errorInfo and errorCode variables may get modified. + * + *---------------------------------------------------------------------- + */ + +int +TclUpdateReturnInfo(iPtr) + Interp *iPtr; /* Interpreter for which TCL_RETURN + * exception is being processed. */ +{ + int code; + + code = iPtr->returnCode; + iPtr->returnCode = TCL_OK; + if (code == TCL_ERROR) { + Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL, + (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE", + TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; + if (iPtr->errorInfo != NULL) { + Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL, + iPtr->errorInfo, TCL_GLOBAL_ONLY); + iPtr->flags |= ERR_IN_PROGRESS; + } + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetInterpProc -- + * + * Returns a pointer to the TclProcInterpProc procedure; this is different + * from the value obtained from the TclProcInterpProc reference on systems + * like Windows where import and export versions of a procedure exported + * by a DLL exist. + * + * Results: + * Returns the internal address of the TclProcInterpProc procedure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclCmdProcType +TclGetInterpProc() +{ + return TclProcInterpProc; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetObjInterpProc -- + * + * Returns a pointer to the TclObjInterpProc procedure; this is different + * from the value obtained from the TclObjInterpProc reference on systems + * like Windows where import and export versions of a procedure exported + * by a DLL exist. + * + * Results: + * Returns the internal address of the TclObjInterpProc procedure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclObjCmdProcType +TclGetObjInterpProc() +{ + return TclObjInterpProc; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewProcBodyObj -- + * + * Creates a new object, of type "procbody", whose internal + * representation is the given Proc struct. + * The newly created object's reference count is 0. + * + * Results: + * Returns a pointer to a newly allocated Tcl_Obj, 0 on error. + * + * Side effects: + * The reference count in the ByteCode attached to the Proc is bumped up + * by one, since the internal rep stores a pointer to it. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclNewProcBodyObj(procPtr) + Proc *procPtr; /* the Proc struct to store as the internal + * representation. */ +{ + Tcl_Obj *objPtr; + + if (!procPtr) { + return (Tcl_Obj *) NULL; + } + + objPtr = Tcl_NewStringObj("", 0); + + if (objPtr) { + objPtr->typePtr = &tclProcBodyType; + objPtr->internalRep.otherValuePtr = (VOID *) procPtr; + + procPtr->refCount++; + } + + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyDup -- + * + * Tcl_ObjType's Dup function for the proc body object. + * Bumps the reference count on the Proc stored in the internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Sets up the object in dupPtr to be a duplicate of the one in srcPtr. + * + *---------------------------------------------------------------------- + */ + +static void ProcBodyDup(srcPtr, dupPtr) + Tcl_Obj *srcPtr; /* object to copy */ + Tcl_Obj *dupPtr; /* target object for the duplication */ +{ + Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr; + + dupPtr->typePtr = &tclProcBodyType; + dupPtr->internalRep.otherValuePtr = (VOID *) procPtr; + procPtr->refCount++; +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyFree -- + * + * Tcl_ObjType's Free function for the proc body object. + * The reference count on its Proc struct is decreased by 1; if the count + * reaches 0, the proc is freed. + * + * Results: + * None. + * + * Side effects: + * If the reference count on the Proc struct reaches 0, the struct is freed. + * + *---------------------------------------------------------------------- + */ + +static void +ProcBodyFree(objPtr) + Tcl_Obj *objPtr; /* the object to clean up */ +{ + Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr; + procPtr->refCount--; + if (procPtr->refCount <= 0) { + TclProcCleanupProc(procPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodySetFromAny -- + * + * Tcl_ObjType's SetFromAny function for the proc body object. + * Calls panic. + * + * Results: + * Theoretically returns a TCL result code. + * + * Side effects: + * Calls panic, since we can't set the value of the object from a string + * representation (or any other internal ones). + * + *---------------------------------------------------------------------- + */ + +static int +ProcBodySetFromAny(interp, objPtr) + Tcl_Interp *interp; /* current interpreter */ + Tcl_Obj *objPtr; /* object pointer */ +{ + panic("called ProcBodySetFromAny"); + + /* + * this to keep compilers happy. + */ + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyUpdateString -- + * + * Tcl_ObjType's UpdateString function for the proc body object. + * Calls panic. + * + * Results: + * None. + * + * Side effects: + * Calls panic, since we this type has no string representation. + * + *---------------------------------------------------------------------- + */ + +static void +ProcBodyUpdateString(objPtr) + Tcl_Obj *objPtr; /* the object to update */ +{ + panic("called ProcBodyUpdateString"); +} diff --git a/tcl/generic/tclRegexp.h b/tcl/generic/tclRegexp.h new file mode 100644 index 00000000000..f04c1ac1904 --- /dev/null +++ b/tcl/generic/tclRegexp.h @@ -0,0 +1,48 @@ +/* + * Definitions etc. for regexp(3) routines. + * + * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof], + * not the System V one. + * + * RCS: @(#) $Id$ + */ + +#ifndef _REGEXP +#define _REGEXP 1 + +#ifndef _TCL +#include "tcl.h" +#endif + +#ifdef BUILD_tcl +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT +#endif + +/* + * NSUBEXP must be at least 10, and no greater than 117 or the parser + * will not work properly. + */ + +#define NSUBEXP 20 + +typedef struct regexp { + char *startp[NSUBEXP]; + char *endp[NSUBEXP]; + char regstart; /* Internal use only. */ + char reganch; /* Internal use only. */ + char *regmust; /* Internal use only. */ + int regmlen; /* Internal use only. */ + char program[1]; /* Unwarranted chumminess with compiler. */ +} regexp; + +EXTERN regexp *TclRegComp _ANSI_ARGS_((char *exp)); +EXTERN int TclRegExec _ANSI_ARGS_((regexp *prog, char *string, char *start)); +EXTERN void TclRegSub _ANSI_ARGS_((regexp *prog, char *source, char *dest)); +EXTERN void TclRegError _ANSI_ARGS_((char *msg)); +EXTERN char *TclGetRegError _ANSI_ARGS_((void)); + +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLIMPORT + +#endif /* REGEXP */ diff --git a/tcl/generic/tclResolve.c b/tcl/generic/tclResolve.c new file mode 100644 index 00000000000..7fea4acffea --- /dev/null +++ b/tcl/generic/tclResolve.c @@ -0,0 +1,418 @@ +/* + * tclResolve.c -- + * + * Contains hooks for customized command/variable name resolution + * schemes. These hooks allow extensions like [incr Tcl] to add + * their own name resolution rules to the Tcl language. Rules can + * be applied to a particular namespace, to the interpreter as a + * whole, or both. + * + * Copyright (c) 1998 Lucent Technologies, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * Declarations for procedures local to this file: + */ + +static void BumpCmdRefEpochs _ANSI_ARGS_((Namespace *nsPtr)); + + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddInterpResolvers -- + * + * Adds a set of command/variable resolution procedures to an + * interpreter. These procedures are consulted when commands + * are resolved in Tcl_FindCommand, and when variables are + * resolved in TclLookupVar and LookupCompiledLocal. Each + * namespace may also have its own set of resolution procedures + * which take precedence over those for the interpreter. + * + * When a name is resolved, it is handled as follows. First, + * the name is passed to the resolution procedures for the + * namespace. If not resolved, the name is passed to each of + * the resolution procedures added to the interpreter. Finally, + * if still not resolved, the name is handled using the default + * Tcl rules for name resolution. + * + * Results: + * Returns pointers to the current name resolution procedures + * in the cmdProcPtr, varProcPtr and compiledVarProcPtr + * arguments. + * + * Side effects: + * If a compiledVarProc is specified, this procedure bumps the + * compileEpoch for the interpreter, forcing all code to be + * recompiled. If a cmdProc is specified, this procedure bumps + * the cmdRefEpoch in all namespaces, forcing commands to be + * resolved again using the new rules. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc) + + Tcl_Interp *interp; /* Interpreter whose name resolution + * rules are being modified. */ + char *name; /* Name of this resolution scheme. */ + Tcl_ResolveCmdProc *cmdProc; /* New procedure for command + * resolution */ + Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution + * at runtime */ + Tcl_ResolveCompiledVarProc *compiledVarProc; + /* Procedure for variable resolution + * at compile time. */ +{ + Interp *iPtr = (Interp*)interp; + ResolverScheme *resPtr; + + /* + * Since we're adding a new name resolution scheme, we must force + * all code to be recompiled to use the new scheme. If there + * are new compiled variable resolution rules, bump the compiler + * epoch to invalidate compiled code. If there are new command + * resolution rules, bump the cmdRefEpoch in all namespaces. + */ + if (compiledVarProc) { + iPtr->compileEpoch++; + } + if (cmdProc) { + BumpCmdRefEpochs(iPtr->globalNsPtr); + } + + /* + * Look for an existing scheme with the given name. If found, + * then replace its rules. + */ + for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) { + if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { + resPtr->cmdResProc = cmdProc; + resPtr->varResProc = varProc; + resPtr->compiledVarResProc = compiledVarProc; + return; + } + } + + /* + * Otherwise, this is a new scheme. Add it to the FRONT + * of the linked list, so that it overrides existing schemes. + */ + resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme)); + resPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1)); + strcpy(resPtr->name, name); + resPtr->cmdResProc = cmdProc; + resPtr->varResProc = varProc; + resPtr->compiledVarResProc = compiledVarProc; + resPtr->nextPtr = iPtr->resolverPtr; + iPtr->resolverPtr = resPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetInterpResolvers -- + * + * Looks for a set of command/variable resolution procedures with + * the given name in an interpreter. These procedures are + * registered by calling Tcl_AddInterpResolvers. + * + * Results: + * If the name is recognized, this procedure returns non-zero, + * along with pointers to the name resolution procedures in + * the Tcl_ResolverInfo structure. If the name is not recognized, + * this procedure returns zero. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetInterpResolvers(interp, name, resInfoPtr) + + Tcl_Interp *interp; /* Interpreter whose name resolution + * rules are being queried. */ + char *name; /* Look for a scheme with this name. */ + Tcl_ResolverInfo *resInfoPtr; /* Returns pointers to the procedures, + * if found */ +{ + Interp *iPtr = (Interp*)interp; + ResolverScheme *resPtr; + + /* + * Look for an existing scheme with the given name. If found, + * then return pointers to its procedures. + */ + for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) { + if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { + resInfoPtr->cmdResProc = resPtr->cmdResProc; + resInfoPtr->varResProc = resPtr->varResProc; + resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc; + return 1; + } + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RemoveInterpResolvers -- + * + * Removes a set of command/variable resolution procedures + * previously added by Tcl_AddInterpResolvers. The next time + * a command/variable name is resolved, these procedures + * won't be consulted. + * + * Results: + * Returns non-zero if the name was recognized and the + * resolution scheme was deleted. Returns zero otherwise. + * + * Side effects: + * If a scheme with a compiledVarProc was deleted, this procedure + * bumps the compileEpoch for the interpreter, forcing all code + * to be recompiled. If a scheme with a cmdProc was deleted, + * this procedure bumps the cmdRefEpoch in all namespaces, + * forcing commands to be resolved again using the new rules. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RemoveInterpResolvers(interp, name) + + Tcl_Interp *interp; /* Interpreter whose name resolution + * rules are being modified. */ + char *name; /* Name of the scheme to be removed. */ +{ + Interp *iPtr = (Interp*)interp; + ResolverScheme **prevPtrPtr, *resPtr; + + /* + * Look for an existing scheme with the given name. + */ + prevPtrPtr = &iPtr->resolverPtr; + for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) { + if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { + break; + } + prevPtrPtr = &resPtr->nextPtr; + } + + /* + * If we found the scheme, delete it. + */ + if (resPtr) { + /* + * If we're deleting a scheme with compiled variable resolution + * rules, bump the compiler epoch to invalidate compiled code. + * If we're deleting a scheme with command resolution rules, + * bump the cmdRefEpoch in all namespaces. + */ + if (resPtr->compiledVarResProc) { + iPtr->compileEpoch++; + } + if (resPtr->cmdResProc) { + BumpCmdRefEpochs(iPtr->globalNsPtr); + } + + *prevPtrPtr = resPtr->nextPtr; + ckfree(resPtr->name); + ckfree((char *) resPtr); + + return 1; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * BumpCmdRefEpochs -- + * + * This procedure is used to bump the cmdRefEpoch counters in + * the specified namespace and all of its child namespaces. + * It is used whenever name resolution schemes are added/removed + * from an interpreter, to invalidate all command references. + * + * Results: + * None. + * + * Side effects: + * Bumps the cmdRefEpoch in the specified namespace and its + * children, recursively. + * + *---------------------------------------------------------------------- + */ + +static void +BumpCmdRefEpochs(nsPtr) + Namespace *nsPtr; /* Namespace being modified. */ +{ + Tcl_HashEntry *entry; + Tcl_HashSearch search; + Namespace *childNsPtr; + + nsPtr->cmdRefEpoch++; + + for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entry != NULL; + entry = Tcl_NextHashEntry(&search)) { + + childNsPtr = (Namespace *) Tcl_GetHashValue(entry); + BumpCmdRefEpochs(childNsPtr); + } +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetNamespaceResolvers -- + * + * Sets the command/variable resolution procedures for a namespace, + * thereby changing the way that command/variable names are + * interpreted. This allows extension writers to support different + * name resolution schemes, such as those for object-oriented + * packages. + * + * Command resolution is handled by a procedure of the following + * type: + * + * typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_(( + * Tcl_Interp* interp, char* name, Tcl_Namespace *context, + * int flags, Tcl_Command *rPtr)); + * + * Whenever a command is executed or Tcl_FindCommand is invoked + * within the namespace, this procedure is called to resolve the + * command name. If this procedure is able to resolve the name, + * it should return the status code TCL_OK, along with the + * corresponding Tcl_Command in the rPtr argument. Otherwise, + * the procedure can return TCL_CONTINUE, and the command will + * be treated under the usual name resolution rules. Or, it can + * return TCL_ERROR, and the command will be considered invalid. + * + * Variable resolution is handled by two procedures. The first + * is called whenever a variable needs to be resolved at compile + * time: + * + * typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_(( + * Tcl_Interp* interp, char* name, Tcl_Namespace *context, + * Tcl_ResolvedVarInfo *rPtr)); + * + * If this procedure is able to resolve the name, it should return + * the status code TCL_OK, along with variable resolution info in + * the rPtr argument; this info will be used to set up compiled + * locals in the call frame at runtime. The procedure may also + * return TCL_CONTINUE, and the variable will be treated under + * the usual name resolution rules. Or, it can return TCL_ERROR, + * and the variable will be considered invalid. + * + * Another procedure is used whenever a variable needs to be + * resolved at runtime but it is not recognized as a compiled local. + * (For example, the variable may be requested via + * Tcl_FindNamespaceVar.) This procedure has the following type: + * + * typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( + * Tcl_Interp* interp, char* name, Tcl_Namespace *context, + * int flags, Tcl_Var *rPtr)); + * + * This procedure is quite similar to the compile-time version. + * It returns the same status codes, but if variable resolution + * succeeds, this procedure returns a Tcl_Var directly via the + * rPtr argument. + * + * Results: + * Nothing. + * + * Side effects: + * Bumps the command epoch counter for the namespace, invalidating + * all command references in that namespace. Also bumps the + * resolver epoch counter for the namespace, forcing all code + * in the namespace to be recompiled. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc) + Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules + * are being modified. */ + Tcl_ResolveCmdProc *cmdProc; /* Procedure for command resolution */ + Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution + * at runtime */ + Tcl_ResolveCompiledVarProc *compiledVarProc; + /* Procedure for variable resolution + * at compile time. */ +{ + Namespace *nsPtr = (Namespace*)namespacePtr; + + /* + * Plug in the new command resolver, and bump the epoch counters + * so that all code will have to be recompiled and all commands + * will have to be resolved again using the new policy. + */ + nsPtr->cmdResProc = cmdProc; + nsPtr->varResProc = varProc; + nsPtr->compiledVarResProc = compiledVarProc; + + nsPtr->cmdRefEpoch++; + nsPtr->resolverEpoch++; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetNamespaceResolvers -- + * + * Returns the current command/variable resolution procedures + * for a namespace. By default, these procedures are NULL. + * New procedures can be installed by calling + * Tcl_SetNamespaceResolvers, to provide new name resolution + * rules. + * + * Results: + * Returns non-zero if any name resolution procedures have been + * assigned to this namespace; also returns pointers to the + * procedures in the Tcl_ResolverInfo structure. Returns zero + * otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetNamespaceResolvers(namespacePtr, resInfoPtr) + + Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules + * are being modified. */ + Tcl_ResolverInfo *resInfoPtr; /* Returns: pointers for all + * name resolution procedures + * assigned to this namespace. */ +{ + Namespace *nsPtr = (Namespace*)namespacePtr; + + resInfoPtr->cmdResProc = nsPtr->cmdResProc; + resInfoPtr->varResProc = nsPtr->varResProc; + resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc; + + if (nsPtr->cmdResProc != NULL || + nsPtr->varResProc != NULL || + nsPtr->compiledVarResProc != NULL) { + return 1; + } + return 0; +} diff --git a/tcl/generic/tclStringObj.c b/tcl/generic/tclStringObj.c new file mode 100644 index 00000000000..ecc9445f208 --- /dev/null +++ b/tcl/generic/tclStringObj.c @@ -0,0 +1,598 @@ +/* + * tclStringObj.c -- + * + * This file contains procedures that implement string operations + * on Tcl objects. To do this efficiently (i.e. to allow many + * appends to be done to an object without constantly reallocating + * the space for the string representation) we overallocate the + * space for the string and use the internal representation to keep + * track of the extra space. Objects with this internal + * representation are called "expandable string objects". + * + * Copyright (c) 1995-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static void ConvertToStringType _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void DupStringInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, + Tcl_Obj *copyPtr)); +static int SetStringFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfString _ANSI_ARGS_((Tcl_Obj *objPtr)); + +/* + * The structure below defines the string Tcl object type by means of + * procedures that can be invoked by generic object code. + */ + +Tcl_ObjType tclStringType = { + "string", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + DupStringInternalRep, /* dupIntRepProc */ + UpdateStringOfString, /* updateStringProc */ + SetStringFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewStringObj -- + * + * This procedure is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new string object and + * initializes it from the byte pointer and length arguments. + * + * When TCL_MEM_DEBUG is defined, this procedure just returns the + * result of calling the debugging version Tcl_DbNewStringObj. + * + * Results: + * A newly created string object is returned that has ref count zero. + * + * Side effects: + * The new object's internal string representation will be set to a + * copy of the length bytes starting at "bytes". If "length" is + * negative, use bytes up to the first NULL byte; i.e., assume "bytes" + * points to a C-style NULL-terminated string. The object's type is set + * to NULL. An extra NULL is added to the end of the new object's byte + * array. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewStringObj + +Tcl_Obj * +Tcl_NewStringObj(bytes, length) + register char *bytes; /* Points to the first of the length bytes + * used to initialize the new object. */ + register int length; /* The number of bytes to copy from "bytes" + * when initializing the new object. If + * negative, use bytes up to the first + * NULL byte. */ +{ + return Tcl_DbNewStringObj(bytes, length, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewStringObj(bytes, length) + register char *bytes; /* Points to the first of the length bytes + * used to initialize the new object. */ + register int length; /* The number of bytes to copy from "bytes" + * when initializing the new object. If + * negative, use bytes up to the first + * NULL byte. */ +{ + register Tcl_Obj *objPtr; + + if (length < 0) { + length = (bytes? strlen(bytes) : 0); + } + TclNewObj(objPtr); + TclInitStringRep(objPtr, bytes, length); + return objPtr; +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewStringObj -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new string objects. It is the + * same as the Tcl_NewStringObj procedure above except that it calls + * Tcl_DbCkalloc directly with the file name and line number from its + * caller. This simplifies debugging since then the checkmem command + * will report the correct file name and line number when reporting + * objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this procedure just returns the + * result of calling Tcl_NewStringObj. + * + * Results: + * A newly created string object is returned that has ref count zero. + * + * Side effects: + * The new object's internal string representation will be set to a + * copy of the length bytes starting at "bytes". If "length" is + * negative, use bytes up to the first NULL byte; i.e., assume "bytes" + * points to a C-style NULL-terminated string. The object's type is set + * to NULL. An extra NULL is added to the end of the new object's byte + * array. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewStringObj(bytes, length, file, line) + register char *bytes; /* Points to the first of the length bytes + * used to initialize the new object. */ + register int length; /* The number of bytes to copy from "bytes" + * when initializing the new object. If + * negative, use bytes up to the first + * NULL byte. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + register Tcl_Obj *objPtr; + + if (length < 0) { + length = (bytes? strlen(bytes) : 0); + } + TclDbNewObj(objPtr, file, line); + TclInitStringRep(objPtr, bytes, length); + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewStringObj(bytes, length, file, line) + register char *bytes; /* Points to the first of the length bytes + * used to initialize the new object. */ + register int length; /* The number of bytes to copy from "bytes" + * when initializing the new object. If + * negative, use bytes up to the first + * NULL byte. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return Tcl_NewStringObj(bytes, length); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetStringObj -- + * + * Modify an object to hold a string that is a copy of the bytes + * indicated by the byte pointer and length arguments. + * + * Results: + * None. + * + * Side effects: + * The object's string representation will be set to a copy of + * the "length" bytes starting at "bytes". If "length" is negative, use + * bytes up to the first NULL byte; i.e., assume "bytes" points to a + * C-style NULL-terminated string. The object's old string and internal + * representations are freed and the object's type is set NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetStringObj(objPtr, bytes, length) + register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ + char *bytes; /* Points to the first of the length bytes + * used to initialize the object. */ + register int length; /* The number of bytes to copy from "bytes" + * when initializing the object. If + * negative, use bytes up to the first + * NULL byte.*/ +{ + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + /* + * Free any old string rep, then set the string rep to a copy of + * the length bytes starting at "bytes". + */ + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetStringObj called with shared object"); + } + + Tcl_InvalidateStringRep(objPtr); + if (length < 0) { + length = strlen(bytes); + } + TclInitStringRep(objPtr, bytes, length); + + /* + * Set the type to NULL and free any internal rep for the old type. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + objPtr->typePtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetObjLength -- + * + * This procedure changes the length of the string representation + * of an object. + * + * Results: + * None. + * + * Side effects: + * If the size of objPtr's string representation is greater than + * length, then it is reduced to length and a new terminating null + * byte is stored in the strength. If the length of the string + * representation is greater than length, the storage space is + * reallocated to the given length; a null byte is stored at the + * end, but other bytes past the end of the original string + * representation are undefined. The object's internal + * representation is changed to "expendable string". + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetObjLength(objPtr, length) + register Tcl_Obj *objPtr; /* Pointer to object. This object must + * not currently be shared. */ + register int length; /* Number of bytes desired for string + * representation of object, not including + * terminating null byte. */ +{ + char *new; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetObjLength called with shared object"); + } + if (objPtr->typePtr != &tclStringType) { + ConvertToStringType(objPtr); + } + + if ((long)length > objPtr->internalRep.longValue) { + /* + * Not enough space in current string. Reallocate the string + * space and free the old string. + */ + + new = (char *) ckalloc((unsigned) (length+1)); + if (objPtr->bytes != NULL) { + memcpy((VOID *) new, (VOID *) objPtr->bytes, + (size_t) objPtr->length); + Tcl_InvalidateStringRep(objPtr); + } + objPtr->bytes = new; + objPtr->internalRep.longValue = (long) length; + } + objPtr->length = length; + if ((objPtr->bytes != NULL) && (objPtr->bytes != tclEmptyStringRep)) { + objPtr->bytes[length] = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendToObj -- + * + * This procedure appends a sequence of bytes to an object. + * + * Results: + * None. + * + * Side effects: + * The bytes at *bytes are appended to the string representation + * of objPtr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendToObj(objPtr, bytes, length) + register Tcl_Obj *objPtr; /* Points to the object to append to. */ + char *bytes; /* Points to the bytes to append to the + * object. */ + register int length; /* The number of bytes to append from + * "bytes". If < 0, then append all bytes + * up to NULL byte. */ +{ + int newLength, oldLength; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_AppendToObj called with shared object"); + } + if (objPtr->typePtr != &tclStringType) { + ConvertToStringType(objPtr); + } + if (length < 0) { + length = strlen(bytes); + } + if (length == 0) { + return; + } + oldLength = objPtr->length; + newLength = length + oldLength; + if ((long)newLength > objPtr->internalRep.longValue) { + /* + * There isn't currently enough space in the string + * representation so allocate additional space. In fact, + * overallocate so that there is room for future growth without + * having to reallocate again. + */ + + Tcl_SetObjLength(objPtr, 2*newLength); + } + if (length > 0) { + memcpy((VOID *) (objPtr->bytes + oldLength), (VOID *) bytes, + (size_t) length); + objPtr->length = newLength; + objPtr->bytes[objPtr->length] = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendStringsToObj -- + * + * This procedure appends one or more null-terminated strings + * to an object. + * + * Results: + * None. + * + * Side effects: + * The contents of all the string arguments are appended to the + * string representation of objPtr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1) +{ + va_list argList; + register Tcl_Obj *objPtr; + int newLength, oldLength; + register char *string, *dst; + + objPtr = (Tcl_Obj *) TCL_VARARGS_START(Tcl_Obj *,arg1,argList); + if (Tcl_IsShared(objPtr)) { + panic("Tcl_AppendStringsToObj called with shared object"); + } + if (objPtr->typePtr != &tclStringType) { + ConvertToStringType(objPtr); + } + + /* + * Figure out how much space is needed for all the strings, and + * expand the string representation if it isn't big enough. If no + * bytes would be appended, just return. + */ + + newLength = oldLength = objPtr->length; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + newLength += strlen(string); + } + if (newLength == oldLength) { + return; + } + + if ((long)newLength > objPtr->internalRep.longValue) { + /* + * There isn't currently enough space in the string + * representation so allocate additional space. If the current + * string representation isn't empty (i.e. it looks like we're + * doing a series of appends) then overallocate the space so + * that we won't have to do as much reallocation in the future. + */ + + Tcl_SetObjLength(objPtr, + (objPtr->length == 0) ? newLength : 2*newLength); + } + + /* + * Make a second pass through the arguments, appending all the + * strings to the object. + */ + + TCL_VARARGS_START(Tcl_Obj *,arg1,argList); + dst = objPtr->bytes + oldLength; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + while (*string != 0) { + *dst = *string; + dst++; + string++; + } + } + + /* + * Add a null byte to terminate the string. However, be careful: + * it's possible that the object is totally empty (if it was empty + * originally and there was nothing to append). In this case dst is + * NULL; just leave everything alone. + */ + + if (dst != NULL) { + *dst = 0; + } + objPtr->length = newLength; + va_end(argList); +} + +/* + *---------------------------------------------------------------------- + * + * ConvertToStringType -- + * + * This procedure converts the internal representation of an object + * to "expandable string" type. + * + * Results: + * None. + * + * Side effects: + * Any old internal reputation for objPtr is freed and the + * internal representation is set to that for an expandable string + * (the field internalRep.longValue holds 1 less than the allocated + * length of objPtr's string representation). + * + *---------------------------------------------------------------------- + */ + +static void +ConvertToStringType(objPtr) + register Tcl_Obj *objPtr; /* Pointer to object. Must have a + * typePtr that isn't &tclStringType. */ +{ + if (objPtr->typePtr != NULL) { + if (objPtr->bytes == NULL) { + objPtr->typePtr->updateStringProc(objPtr); + } + if (objPtr->typePtr->freeIntRepProc != NULL) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + } + objPtr->typePtr = &tclStringType; + if (objPtr->bytes != NULL) { + objPtr->internalRep.longValue = (long)objPtr->length; + } else { + objPtr->internalRep.longValue = 0; + objPtr->length = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * DupStringInternalRep -- + * + * Initialize the internal representation of a new Tcl_Obj to a + * copy of the internal representation of an existing string object. + * + * Results: + * None. + * + * Side effects: + * copyPtr's internal rep is set to a copy of srcPtr's internal + * representation. + * + *---------------------------------------------------------------------- + */ + +static void +DupStringInternalRep(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. Must + * have an internal representation of type + * "expandable string". */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. Must + * not currently have an internal rep.*/ +{ + /* + * Tricky point: the string value was copied by generic object + * management code, so it doesn't contain any extra bytes that + * might exist in the source object. + */ + + copyPtr->internalRep.longValue = (long)copyPtr->length; + copyPtr->typePtr = &tclStringType; +} + +/* + *---------------------------------------------------------------------- + * + * SetStringFromAny -- + * + * Create an internal representation of type "expandable string" + * for an object. + * + * Results: + * This operation always succeeds and returns TCL_OK. + * + * Side effects: + * This procedure does nothing; there is no advantage in converting + * the internal representation now, so we just defer it. + * + *---------------------------------------------------------------------- + */ + +static int +SetStringFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfString -- + * + * Update the string representation for an object whose internal + * representation is "expandable string". + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfString(objPtr) + Tcl_Obj *objPtr; /* Object with string rep to update. */ +{ + /* + * The string is almost always valid already, in which case there's + * nothing for us to do. The only case we have to worry about is if + * the object is totally null. In this case, set the string rep to + * an empty string. + */ + + if (objPtr->bytes == NULL) { + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; + } + return; +} diff --git a/tcl/generic/tclTest.c b/tcl/generic/tclTest.c new file mode 100644 index 00000000000..49c8fe11296 --- /dev/null +++ b/tcl/generic/tclTest.c @@ -0,0 +1,3096 @@ +/* + * tclTest.c -- + * + * This file contains C command procedures for a bunch of additional + * Tcl commands that are used for testing out Tcl's C interfaces. + * These commands are not normally included in Tcl applications; + * they're only used for testing. + * + * Copyright (c) 1993-1994 The Regents of the University of California. + * Copyright (c) 1994-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. + * + * RCS: @(#) $Id$ + */ + +#define TCL_TEST + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Declare external functions used in Windows tests. + */ + +#if defined(__WIN32__) +extern TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void)); +#endif + +/* + * Dynamic string shared by TestdcallCmd and DelCallbackProc; used + * to collect the results of the various deletion callbacks. + */ + +static Tcl_DString delString; +static Tcl_Interp *delInterp; + +/* + * One of the following structures exists for each asynchronous + * handler created by the "testasync" command". + */ + +typedef struct TestAsyncHandler { + int id; /* Identifier for this handler. */ + Tcl_AsyncHandler handler; /* Tcl's token for the handler. */ + char *command; /* Command to invoke when the + * handler is invoked. */ + struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */ +} TestAsyncHandler; + +static TestAsyncHandler *firstHandler = NULL; + +/* + * The dynamic string below is used by the "testdstring" command + * to test the dynamic string facilities. + */ + +static Tcl_DString dstring; + +/* + * The command trace below is used by the "testcmdtraceCmd" command + * to test the command tracing facilities. + */ + +static Tcl_Trace cmdTrace; + +/* + * One of the following structures exists for each command created + * by TestdelCmd: + */ + +typedef struct DelCmd { + Tcl_Interp *interp; /* Interpreter in which command exists. */ + char *deleteCmd; /* Script to execute when command is + * deleted. Malloc'ed. */ +} DelCmd; + +/* + * Forward declarations for procedures defined later in this file: + */ + +int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +static void CleanupTestSetassocdataTests _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData)); +static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData)); +static int CmdProc1 _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int CmdProc2 _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void CmdTraceDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int level, char *command, Tcl_CmdProc *cmdProc, + ClientData cmdClientData, int argc, + char **argv)); +static void CmdTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int level, char *command, + Tcl_CmdProc *cmdProc, ClientData cmdClientData, + int argc, char **argv)); +static int CreatedCommandProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +static int CreatedCommandProc2 _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +static void DelCallbackProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static int DelCmdProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void DelDeleteProc _ANSI_ARGS_((ClientData clientData)); +static void ExitProcEven _ANSI_ARGS_((ClientData clientData)); +static void ExitProcOdd _ANSI_ARGS_((ClientData clientData)); +static int GetTimesCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int NoopCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int NoopObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static void SpecialFree _ANSI_ARGS_((char *blockPtr)); +static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp)); +static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestAccessProc1 _ANSI_ARGS_((CONST char *path, + int mode)); +static int TestAccessProc2 _ANSI_ARGS_((CONST char *path, + int mode)); +static int TestAccessProc3 _ANSI_ARGS_((CONST char *path, + int mode)); +static int TestasyncCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestchmodCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdcallCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdelCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdstringCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfileCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfeventCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetvarfullnameCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestlinkCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestMathFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_((Tcl_Interp *interp, + char *filename, char *modeString, int permissions)); +static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((Tcl_Interp *interp, + char *filename, char *modeString, int permissions)); +static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((Tcl_Interp *interp, + char *filename, char *modeString, int permissions)); +static int TestPanicCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetnoerrCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetobjerrorcodeCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int TestopenfilechannelprocCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetrecursionlimitCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestStatProc1 _ANSI_ARGS_((CONST char *path, + TclStat_ *buf)); +static int TestStatProc2 _ANSI_ARGS_((CONST char *path, + TclStat_ *buf)); +static int TestStatProc3 _ANSI_ARGS_((CONST char *path, + TclStat_ *buf)); +static int TeststatprocCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestwordendObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); + +/* + * External (platform specific) initialization routine: + */ + +EXTERN int TclplatformtestInit _ANSI_ARGS_(( + Tcl_Interp *interp)); + +/* + *---------------------------------------------------------------------- + * + * Tcltest_Init -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcltest_Init(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + Tcl_ValueType t3ArgTypes[2]; + + if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Create additional commands and math functions for testing Tcl. + */ + + Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testchannel", TclTestChannelCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testchannelevent", TclTestChannelEventCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testchmod", TestchmodCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_DStringInit(&dstring); + Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfile", TestfileCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testgetvarfullname", + TestgetvarfullnameCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testopenfilechannelproc", + TestopenfilechannelprocCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsetnoerr", TestsetnoerrCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testsetobjerrorcode", + TestsetobjerrorcodeCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testsetrecursionlimit", + TestsetrecursionlimitCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testtranslatefilename", + TesttranslatefilenameCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testwordend", TestwordendObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testpanic", TestPanicCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc, + (ClientData) 123); + Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc, + (ClientData) 345); + Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + t3ArgTypes[0] = TCL_EITHER; + t3ArgTypes[1] = TCL_EITHER; + Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, + (ClientData) 0); + + /* + * And finally add any platform specific test commands. + */ + + return TclplatformtestInit(interp); +} + +/* + *---------------------------------------------------------------------- + * + * TestasyncCmd -- + * + * This procedure implements the "testasync" command. It is used + * to test the asynchronous handler facilities of Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestasyncCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TestAsyncHandler *asyncPtr, *prevPtr; + int id, code; + static int nextId = 1; + char buf[30]; + + if (argc < 2) { + wrongNumArgs: + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler)); + asyncPtr->id = nextId; + nextId++; + asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, + (ClientData) asyncPtr); + asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1)); + strcpy(asyncPtr->command, argv[2]); + asyncPtr->nextPtr = firstHandler; + firstHandler = asyncPtr; + sprintf(buf, "%d", asyncPtr->id); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else if (strcmp(argv[1], "delete") == 0) { + if (argc == 2) { + while (firstHandler != NULL) { + asyncPtr = firstHandler; + firstHandler = asyncPtr->nextPtr; + Tcl_AsyncDelete(asyncPtr->handler); + ckfree(asyncPtr->command); + ckfree((char *) asyncPtr); + } + return TCL_OK; + } + if (argc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { + return TCL_ERROR; + } + for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL; + prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id != id) { + continue; + } + if (prevPtr == NULL) { + firstHandler = asyncPtr->nextPtr; + } else { + prevPtr->nextPtr = asyncPtr->nextPtr; + } + Tcl_AsyncDelete(asyncPtr->handler); + ckfree(asyncPtr->command); + ckfree((char *) asyncPtr); + break; + } + } else if (strcmp(argv[1], "mark") == 0) { + if (argc != 5) { + goto wrongNumArgs; + } + if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK) + || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { + return TCL_ERROR; + } + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) { + Tcl_AsyncMark(asyncPtr->handler); + break; + } + } + Tcl_SetResult(interp, argv[3], TCL_VOLATILE); + return code; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, int, or mark", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static int +AsyncHandlerProc(clientData, interp, code) + ClientData clientData; /* Pointer to TestAsyncHandler structure. */ + Tcl_Interp *interp; /* Interpreter in which command was + * executed, or NULL. */ + int code; /* Current return code from command. */ +{ + TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; + char *listArgv[4]; + char string[20], *cmd; + + sprintf(string, "%d", code); + listArgv[0] = asyncPtr->command; + listArgv[1] = interp->result; + listArgv[2] = string; + listArgv[3] = NULL; + cmd = Tcl_Merge(3, listArgv); + code = Tcl_Eval(interp, cmd); + ckfree(cmd); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TestcmdinfoCmd -- + * + * This procedure implements the "testcmdinfo" command. It is used + * to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation + * and deletion. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various commands and modifies their data. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcmdinfoCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_CmdInfo info; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option cmdName\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", + CmdDelProc1); + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_DStringInit(&delString); + Tcl_DeleteCommand(interp, argv[2]); + Tcl_DStringResult(interp, &delString); + } else if (strcmp(argv[1], "get") == 0) { + if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { + Tcl_SetResult(interp, "??", TCL_STATIC); + return TCL_OK; + } + if (info.proc == CmdProc1) { + Tcl_AppendResult(interp, "CmdProc1", " ", + (char *) info.clientData, (char *) NULL); + } else if (info.proc == CmdProc2) { + Tcl_AppendResult(interp, "CmdProc2", " ", + (char *) info.clientData, (char *) NULL); + } else { + Tcl_AppendResult(interp, "unknown", (char *) NULL); + } + if (info.deleteProc == CmdDelProc1) { + Tcl_AppendResult(interp, " CmdDelProc1", " ", + (char *) info.deleteData, (char *) NULL); + } else if (info.deleteProc == CmdDelProc2) { + Tcl_AppendResult(interp, " CmdDelProc2", " ", + (char *) info.deleteData, (char *) NULL); + } else { + Tcl_AppendResult(interp, " unknown", (char *) NULL); + } + Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, + (char *) NULL); + if (info.isNativeObjectProc) { + Tcl_AppendResult(interp, " nativeObjectProc", (char *) NULL); + } else { + Tcl_AppendResult(interp, " stringProc", (char *) NULL); + } + } else if (strcmp(argv[1], "modify") == 0) { + info.proc = CmdProc2; + info.clientData = (ClientData) "new_command_data"; + info.objProc = NULL; + info.objClientData = (ClientData) NULL; + info.deleteProc = CmdDelProc2; + info.deleteData = (ClientData) "new_delete_data"; + if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { + Tcl_SetResult(interp, "0", TCL_STATIC); + } else { + Tcl_SetResult(interp, "1", TCL_STATIC); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, get, or modify", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + + /*ARGSUSED*/ +static int +CmdProc1(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, + (char *) NULL); + return TCL_OK; +} + + /*ARGSUSED*/ +static int +CmdProc2(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, + (char *) NULL); + return TCL_OK; +} + +static void +CmdDelProc1(clientData) + ClientData clientData; /* String to save. */ +{ + Tcl_DStringInit(&delString); + Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); + Tcl_DStringAppend(&delString, (char *) clientData, -1); +} + +static void +CmdDelProc2(clientData) + ClientData clientData; /* String to save. */ +{ + Tcl_DStringInit(&delString); + Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); + Tcl_DStringAppend(&delString, (char *) clientData, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TestcmdtokenCmd -- + * + * This procedure implements the "testcmdtoken" command. It is used + * to test Tcl_Command tokens and procedures such as + * Tcl_GetCommandFullName. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various commands and modifies their data. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcmdtokenCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Command token; + long int l; + char buf[30]; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option arg\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + token = Tcl_CreateCommand(interp, argv[2], CmdProc1, + (ClientData) "original", (Tcl_CmdDeleteProc *) NULL); + sprintf(buf, "%lx", (long int) token); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else if (strcmp(argv[1], "name") == 0) { + Tcl_Obj *objPtr; + + if (sscanf(argv[2], "%lx", &l) != 1) { + Tcl_AppendResult(interp, "bad command token \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + + objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr); + + Tcl_AppendElement(interp, + Tcl_GetCommandName(interp, (Tcl_Command) l)); + Tcl_AppendElement(interp, + Tcl_GetStringFromObj(objPtr, (int *) NULL)); + Tcl_DecrRefCount(objPtr); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create or name", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestcmdtraceCmd -- + * + * This procedure implements the "testcmdtrace" command. It is used + * to test Tcl_CreateTrace and Tcl_DeleteTrace. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes a command trace, and tests the invocation of + * a procedure by the command trace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcmdtraceCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_DString buffer; + int result; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option script\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "tracetest") == 0) { + Tcl_DStringInit(&buffer); + cmdTrace = Tcl_CreateTrace(interp, 50000, + (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); + result = Tcl_Eval(interp, argv[2]); + if (result == TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); + } + Tcl_DeleteTrace(interp, cmdTrace); + Tcl_DStringFree(&buffer); + } else if (strcmp(argv[1], "deletetest") == 0) { + /* + * Create a command trace then eval a script to check whether it is + * called. Note that this trace procedure removes itself as a + * further check of the robustness of the trace proc calling code in + * TclExecuteByteCode. + */ + + cmdTrace = Tcl_CreateTrace(interp, 50000, + (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL); + result = Tcl_Eval(interp, argv[2]); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be tracetest or deletetest", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static void +CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData, + argc, argv) + ClientData clientData; /* Pointer to buffer in which the + * command and arguments are appended. + * Accumulates test result. */ + Tcl_Interp *interp; /* Current interpreter. */ + int level; /* Current trace level. */ + char *command; /* The command being traced (after + * substitutions). */ + Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */ + ClientData cmdClientData; /* Client data associated with command + * procedure. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_DString *bufPtr = (Tcl_DString *) clientData; + int i; + + Tcl_DStringAppendElement(bufPtr, command); + + Tcl_DStringStartSublist(bufPtr); + for (i = 0; i < argc; i++) { + Tcl_DStringAppendElement(bufPtr, argv[i]); + } + Tcl_DStringEndSublist(bufPtr); +} + +static void +CmdTraceDeleteProc(clientData, interp, level, command, cmdProc, + cmdClientData, argc, argv) + ClientData clientData; /* Unused. */ + Tcl_Interp *interp; /* Current interpreter. */ + int level; /* Current trace level. */ + char *command; /* The command being traced (after + * substitutions). */ + Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */ + ClientData cmdClientData; /* Client data associated with command + * procedure. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + /* + * Remove ourselves to test whether calling Tcl_DeleteTrace within + * a trace callback causes the for loop in TclExecuteByteCode that + * calls traces to reference freed memory. + */ + + Tcl_DeleteTrace(interp, cmdTrace); +} + +/* + *---------------------------------------------------------------------- + * + * TestcreatecommandCmd -- + * + * This procedure implements the "testcreatecommand" command. It is + * used to test that the Tcl_CreateCommand creates a new command in + * the namespace specified as part of its name, if any. It also + * checks that the namespace code ignore single ":"s in the middle + * or end of a command name. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes two commands ("test_ns_basic::createdcommand" + * and "value:at:"). + * + *---------------------------------------------------------------------- + */ + +static int +TestcreatecommandCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + Tcl_CreateCommand(interp, "test_ns_basic::createdcommand", + CreatedCommandProc, (ClientData) NULL, + (Tcl_CmdDeleteProc *) NULL); + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_DeleteCommand(interp, "test_ns_basic::createdcommand"); + } else if (strcmp(argv[1], "create2") == 0) { + Tcl_CreateCommand(interp, "value:at:", + CreatedCommandProc2, (ClientData) NULL, + (Tcl_CmdDeleteProc *) NULL); + } else if (strcmp(argv[1], "delete2") == 0) { + Tcl_DeleteCommand(interp, "value:at:"); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, create2, or delete2", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static int +CreatedCommandProc(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_CmdInfo info; + int found; + + found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand", + &info); + if (!found) { + Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand", + (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, "CreatedCommandProc in ", + info.namespacePtr->fullName, (char *) NULL); + return TCL_OK; +} + +static int +CreatedCommandProc2(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_CmdInfo info; + int found; + + found = Tcl_GetCommandInfo(interp, "value:at:", &info); + if (!found) { + Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand", + (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, "CreatedCommandProc2 in ", + info.namespacePtr->fullName, (char *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestdcallCmd -- + * + * This procedure implements the "testdcall" command. It is used + * to test Tcl_CallWhenDeleted. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdcallCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, id; + + delInterp = Tcl_CreateInterp(); + Tcl_DStringInit(&delString); + for (i = 1; i < argc; i++) { + if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) { + return TCL_ERROR; + } + if (id < 0) { + Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, + (ClientData) (-id)); + } else { + Tcl_CallWhenDeleted(delInterp, DelCallbackProc, + (ClientData) id); + } + } + Tcl_DeleteInterp(delInterp); + Tcl_DStringResult(interp, &delString); + return TCL_OK; +} + +/* + * The deletion callback used by TestdcallCmd: + */ + +static void +DelCallbackProc(clientData, interp) + ClientData clientData; /* Numerical value to append to + * delString. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + int id = (int) clientData; + char buffer[10]; + + sprintf(buffer, "%d", id); + Tcl_DStringAppendElement(&delString, buffer); + if (interp != delInterp) { + Tcl_DStringAppendElement(&delString, "bogus interpreter argument!"); + } +} + +/* + *---------------------------------------------------------------------- + * + * TestdelCmd -- + * + * This procedure implements the "testdcall" command. It is used + * to test Tcl_CallWhenDeleted. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdelCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + DelCmd *dPtr; + Tcl_Interp *slave; + + if (argc != 4) { + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + return TCL_ERROR; + } + + slave = Tcl_GetSlave(interp, argv[1]); + if (slave == NULL) { + return TCL_ERROR; + } + + dPtr = (DelCmd *) ckalloc(sizeof(DelCmd)); + dPtr->interp = interp; + dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1)); + strcpy(dPtr->deleteCmd, argv[3]); + + Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, + DelDeleteProc); + return TCL_OK; +} + +static int +DelCmdProc(clientData, interp, argc, argv) + ClientData clientData; /* String result to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + DelCmd *dPtr = (DelCmd *) clientData; + + Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL); + ckfree(dPtr->deleteCmd); + ckfree((char *) dPtr); + return TCL_OK; +} + +static void +DelDeleteProc(clientData) + ClientData clientData; /* String command to evaluate. */ +{ + DelCmd *dPtr = (DelCmd *) clientData; + + Tcl_Eval(dPtr->interp, dPtr->deleteCmd); + Tcl_ResetResult(dPtr->interp); + ckfree(dPtr->deleteCmd); + ckfree((char *) dPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TestdelassocdataCmd -- + * + * This procedure implements the "testdelassocdata" command. It is used + * to test Tcl_DeleteAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes an association between a key and associated data from an + * interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +TestdelassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_DeleteAssocData(interp, argv[1]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestdstringCmd -- + * + * This procedure implements the "testdstring" command. It is used + * to test the dynamic string facilities of Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdstringCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int count; + + if (argc < 2) { + wrongNumArgs: + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + return TCL_ERROR; + } + if (strcmp(argv[1], "append") == 0) { + if (argc != 4) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringAppend(&dstring, argv[2], count); + } else if (strcmp(argv[1], "element") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + Tcl_DStringAppendElement(&dstring, argv[2]); + } else if (strcmp(argv[1], "end") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringEndSublist(&dstring); + } else if (strcmp(argv[1], "free") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringFree(&dstring); + } else if (strcmp(argv[1], "get") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_SetResult(interp, Tcl_DStringValue(&dstring), TCL_VOLATILE); + } else if (strcmp(argv[1], "gresult") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + if (strcmp(argv[2], "staticsmall") == 0) { + Tcl_SetResult(interp, "short", TCL_STATIC); + } else if (strcmp(argv[2], "staticlarge") == 0) { + Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC); + } else if (strcmp(argv[2], "free") == 0) { + Tcl_SetResult(interp, (char *) ckalloc(100), TCL_DYNAMIC); + strcpy(interp->result, "This is a malloc-ed string"); + } else if (strcmp(argv[2], "special") == 0) { + interp->result = (char *) ckalloc(100); + interp->result += 4; + interp->freeProc = SpecialFree; + strcpy(interp->result, "This is a specially-allocated string"); + } else { + Tcl_AppendResult(interp, "bad gresult option \"", argv[2], + "\": must be staticsmall, staticlarge, free, or special", + (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringGetResult(interp, &dstring); + } else if (strcmp(argv[1], "length") == 0) { + char buf[30]; + + if (argc != 2) { + goto wrongNumArgs; + } + sprintf(buf, "%d", Tcl_DStringLength(&dstring)); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else if (strcmp(argv[1], "result") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringResult(interp, &dstring); + } else if (strcmp(argv[1], "trunc") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringTrunc(&dstring, count); + } else if (strcmp(argv[1], "start") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringStartSublist(&dstring); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be append, element, end, free, get, length, ", + "result, trunc, or start", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * The procedure below is used as a special freeProc to test how well + * Tcl_DStringGetResult handles freeProc's other than free. + */ + +static void SpecialFree(blockPtr) + char *blockPtr; /* Block to free. */ +{ + ckfree(blockPtr - 4); +} + +/* + *---------------------------------------------------------------------- + * + * TestexithandlerCmd -- + * + * This procedure implements the "testexithandler" command. It is + * used to test Tcl_CreateExitHandler and Tcl_DeleteExitHandler. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexithandlerCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int value; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " create|delete value\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, + (ClientData) value); + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, + (ClientData) value); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create or delete", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static void +ExitProcOdd(clientData) + ClientData clientData; /* Integer value to print. */ +{ + char buf[100]; + + sprintf(buf, "odd %d\n", (int) clientData); + write(1, buf, strlen(buf)); +} + +static void +ExitProcEven(clientData) + ClientData clientData; /* Integer value to print. */ +{ + char buf[100]; + + sprintf(buf, "even %d\n", (int) clientData); + write(1, buf, strlen(buf)); +} + +/* + *---------------------------------------------------------------------- + * + * TestexprlongCmd -- + * + * This procedure verifies that Tcl_ExprLong does not modify the + * interpreter result if there is no error. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexprlongCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + long exprResult; + char buf[30]; + int result; + + Tcl_SetResult(interp, "This is a result", TCL_STATIC); + result = Tcl_ExprLong(interp, "4+1", &exprResult); + if (result != TCL_OK) { + return result; + } + sprintf(buf, ": %ld", exprResult); + Tcl_AppendResult(interp, buf, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestexprstringCmd -- + * + * This procedure tests the basic operation of Tcl_ExprString. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexprstringCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " expression\"", (char *) NULL); + return TCL_ERROR; + } + return Tcl_ExprString(interp, argv[1]); +} + +/* + *---------------------------------------------------------------------- + * + * TestgetassocdataCmd -- + * + * This procedure implements the "testgetassocdata" command. It is + * used to test Tcl_GetAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *res; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key\"", (char *) NULL); + return TCL_ERROR; + } + res = (char *) Tcl_GetAssocData(interp, argv[1], NULL); + if (res != NULL) { + Tcl_AppendResult(interp, res, NULL); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestgetplatformCmd -- + * + * This procedure implements the "testgetplatform" command. It is + * used to retrievel the value of the tclPlatform global variable. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetplatformCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static char *platformStrings[] = { "unix", "mac", "windows" }; + TclPlatformType *platform; + +#ifdef __WIN32__ + platform = TclWinGetPlatform(); +#else + platform = &tclPlatform; +#endif + + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + (char *) NULL); + return TCL_ERROR; + } + + Tcl_AppendResult(interp, platformStrings[*platform], NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestinterpdeleteCmd -- + * + * This procedure tests the code in tclInterp.c that deals with + * interpreter deletion. It deletes a user-specified interpreter + * from the hierarchy, and subsequent code checks integrity. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes one or more interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestinterpdeleteCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *slaveToDelete; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " path\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[1][0] == '\0') { + Tcl_AppendResult(interp, "cannot delete current interpreter", + (char *) NULL); + return TCL_ERROR; + } + slaveToDelete = Tcl_GetSlave(interp, argv[1]); + if (slaveToDelete == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[1], "\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_DeleteInterp(slaveToDelete); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestlinkCmd -- + * + * This procedure implements the "testlink" command. It is used + * to test Tcl_LinkVar and related library procedures. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various variable links, plus returns + * values of the linked variables. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestlinkCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static int intVar = 43; + static int boolVar = 4; + static double realVar = 1.23; + static char *stringVar = NULL; + static int created = 0; + char buffer[TCL_DOUBLE_SPACE]; + int writable, flag; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg arg?\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + if (created) { + Tcl_UnlinkVar(interp, "int"); + Tcl_UnlinkVar(interp, "real"); + Tcl_UnlinkVar(interp, "bool"); + Tcl_UnlinkVar(interp, "string"); + } + created = 1; + if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "int", (char *) &intVar, + TCL_LINK_INT | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "real", (char *) &realVar, + TCL_LINK_DOUBLE | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "bool", (char *) &boolVar, + TCL_LINK_BOOLEAN | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "string", (char *) &stringVar, + TCL_LINK_STRING | flag) != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_UnlinkVar(interp, "int"); + Tcl_UnlinkVar(interp, "real"); + Tcl_UnlinkVar(interp, "bool"); + Tcl_UnlinkVar(interp, "string"); + created = 0; + } else if (strcmp(argv[1], "get") == 0) { + sprintf(buffer, "%d", intVar); + Tcl_AppendElement(interp, buffer); + Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer); + Tcl_AppendElement(interp, buffer); + sprintf(buffer, "%d", boolVar); + Tcl_AppendElement(interp, buffer); + Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); + } else if (strcmp(argv[1], "set") == 0) { + if (argc != 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], + "intValue realValue boolValue stringValue\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] != 0) { + if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[3][0] != 0) { + if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[4][0] != 0) { + if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[5][0] != 0) { + if (stringVar != NULL) { + ckfree(stringVar); + } + if (strcmp(argv[5], "-") == 0) { + stringVar = NULL; + } else { + stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + strcpy(stringVar, argv[5]); + } + } + } else if (strcmp(argv[1], "update") == 0) { + if (argc != 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], + "intValue realValue boolValue stringValue\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] != 0) { + if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { + return TCL_ERROR; + } + Tcl_UpdateLinkedVar(interp, "int"); + } + if (argv[3][0] != 0) { + if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { + return TCL_ERROR; + } + Tcl_UpdateLinkedVar(interp, "real"); + } + if (argv[4][0] != 0) { + if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { + return TCL_ERROR; + } + Tcl_UpdateLinkedVar(interp, "bool"); + } + if (argv[5][0] != 0) { + if (stringVar != NULL) { + ckfree(stringVar); + } + if (strcmp(argv[5], "-") == 0) { + stringVar = NULL; + } else { + stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + strcpy(stringVar, argv[5]); + } + Tcl_UpdateLinkedVar(interp, "string"); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be create, delete, get, set, or update", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestMathFunc -- + * + * This is a user-defined math procedure to test out math procedures + * with no arguments. + * + * Results: + * A normal Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestMathFunc(clientData, interp, args, resultPtr) + ClientData clientData; /* Integer value to return. */ + Tcl_Interp *interp; /* Not used. */ + Tcl_Value *args; /* Not used. */ + Tcl_Value *resultPtr; /* Where to store result. */ +{ + resultPtr->type = TCL_INT; + resultPtr->intValue = (int) clientData; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestMathFunc2 -- + * + * This is a user-defined math procedure to test out math procedures + * that do have arguments, in this case 2. + * + * Results: + * A normal Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestMathFunc2(clientData, interp, args, resultPtr) + ClientData clientData; /* Integer value to return. */ + Tcl_Interp *interp; /* Used to report errors. */ + Tcl_Value *args; /* Points to an array of two + * Tcl_Values for the two + * arguments. */ + Tcl_Value *resultPtr; /* Where to store the result. */ +{ + int result = TCL_OK; + + /* + * Return the maximum of the two arguments with the correct type. + */ + + if (args[0].type == TCL_INT) { + int i0 = args[0].intValue; + + if (args[1].type == TCL_INT) { + int i1 = args[1].intValue; + + resultPtr->type = TCL_INT; + resultPtr->intValue = ((i0 > i1)? i0 : i1); + } else if (args[1].type == TCL_DOUBLE) { + double d0 = i0; + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else { + Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } + } else if (args[0].type == TCL_DOUBLE) { + double d0 = args[0].doubleValue; + + if (args[1].type == TCL_INT) { + double d1 = args[1].intValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_DOUBLE) { + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else { + Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } + } else { + Tcl_SetResult(interp, "T2: wrong type for arg 1", TCL_STATIC); + result = TCL_ERROR; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * CleanupTestSetassocdataTests -- + * + * This function is called when an interpreter is deleted to clean + * up any data left over from running the testsetassocdata command. + * + * Results: + * None. + * + * Side effects: + * Releases storage. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +static void +CleanupTestSetassocdataTests(clientData, interp) + ClientData clientData; /* Data to be released. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + ckfree((char *) clientData); +} + +/* + *---------------------------------------------------------------------- + * + * TestsetassocdataCmd -- + * + * This procedure implements the "testsetassocdata" command. It is used + * to test Tcl_SetAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Modifies or creates an association between a key and associated + * data for this interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *buf; + char *oldData; + Tcl_InterpDeleteProc *procPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key data_item\"", (char *) NULL); + return TCL_ERROR; + } + + buf = ckalloc((unsigned) strlen(argv[2]) + 1); + strcpy(buf, argv[2]); + + /* + * If we previously associated a malloced value with the variable, + * free it before associating a new value. + */ + + oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr); + if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) { + ckfree(oldData); + } + + Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, + (ClientData) buf); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestsetplatformCmd -- + * + * This procedure implements the "testsetplatform" command. It is + * used to change the tclPlatform global variable so all file + * name conversions can be tested on a single platform. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets the tclPlatform global variable. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetplatformCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + size_t length; + TclPlatformType *platform; + +#ifdef __WIN32__ + platform = TclWinGetPlatform(); +#else + platform = &tclPlatform; +#endif + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " platform\"", (char *) NULL); + return TCL_ERROR; + } + + length = strlen(argv[1]); + if (strncmp(argv[1], "unix", length) == 0) { + *platform = TCL_PLATFORM_UNIX; + } else if (strncmp(argv[1], "mac", length) == 0) { + *platform = TCL_PLATFORM_MAC; + } else if (strncmp(argv[1], "windows", length) == 0) { + *platform = TCL_PLATFORM_WINDOWS; + } else { + Tcl_AppendResult(interp, "unsupported platform: should be one of ", + "unix, mac, or windows", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestsetrecursionlimitCmd -- + * + * This procedure implements the "testsetrecursionlimit" command. It is + * used to change the interp recursion limit (to test the effects + * of Tcl_SetRecursionLimit). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets the interp's recursion limit. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetrecursionlimitCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + int value; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "integer"); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { + return TCL_ERROR; + } + value = Tcl_SetRecursionLimit(interp, value); + Tcl_SetIntObj(Tcl_GetObjResult(interp), value); + return TCL_OK; +} + + + +/* + *---------------------------------------------------------------------- + * + * TeststaticpkgCmd -- + * + * This procedure implements the "teststaticpkg" command. + * It is used to test the procedure Tcl_StaticPackage. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * When the packge given by argv[1] is loaded into an interpeter, + * variable "x" in that interpreter is set to "loaded". + * + *---------------------------------------------------------------------- + */ + +static int +TeststaticpkgCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int safe, loaded; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " pkgName safe loaded\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { + return TCL_ERROR; + } + Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, + (safe) ? StaticInitProc : NULL); + return TCL_OK; +} + +static int +StaticInitProc(interp) + Tcl_Interp *interp; /* Interpreter in which package + * is supposedly being loaded. */ +{ + Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TesttranslatefilenameCmd -- + * + * This procedure implements the "testtranslatefilename" command. + * It is used to test the Tcl_TranslateFileName command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TesttranslatefilenameCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_DString buffer; + char *result; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " path\"", (char *) NULL); + return TCL_ERROR; + } + result = Tcl_TranslateFileName(interp, argv[1], &buffer); + if (result == NULL) { + return TCL_ERROR; + } + Tcl_AppendResult(interp, result, NULL); + Tcl_DStringFree(&buffer); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestupvarCmd -- + * + * This procedure implements the "testupvar2" command. It is used + * to test Tcl_UpVar and Tcl_UpVar2. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates or modifies an "upvar" reference. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestupvarCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int flags = 0; + + if ((argc != 5) && (argc != 6)) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " level name ?name2? dest global\"", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 5) { + if (strcmp(argv[4], "global") == 0) { + flags = TCL_GLOBAL_ONLY; + } else if (strcmp(argv[4], "namespace") == 0) { + flags = TCL_NAMESPACE_ONLY; + } + return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags); + } else { + if (strcmp(argv[5], "global") == 0) { + flags = TCL_GLOBAL_ONLY; + } else if (strcmp(argv[5], "namespace") == 0) { + flags = TCL_NAMESPACE_ONLY; + } + return Tcl_UpVar2(interp, argv[1], argv[2], + (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4], + flags); + } +} + +/* + *---------------------------------------------------------------------- + * + * TestwordendCmd -- + * + * This procedure implements the "testwordend" command. It is used + * to test TclWordEnd. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestwordendObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + Tcl_Obj *objPtr; + char *string, *end; + int length; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } + objPtr = Tcl_GetObjResult(interp); + string = Tcl_GetStringFromObj(objv[1], &length); + end = TclWordEnd(string, string+length, 0, NULL); + Tcl_AppendToObj(objPtr, end, length - (end - string)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestsetobjerrorcodeCmd -- + * + * This procedure implements the "testsetobjerrorcodeCmd". + * This tests up to five elements passed to the + * Tcl_SetObjErrorCode command. + * + * Results: + * A standard Tcl result. Always returns TCL_ERROR so that + * the error code can be tested. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestsetobjerrorcodeCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + Tcl_Obj *listObjPtr; + + if (objc > 1) { + listObjPtr = Tcl_ConcatObj(objc - 1, objv + 1); + } else { + listObjPtr = Tcl_NewObj(); + } + Tcl_IncrRefCount(listObjPtr); + Tcl_SetObjErrorCode(interp, listObjPtr); + Tcl_DecrRefCount(listObjPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TestfeventCmd -- + * + * This procedure implements the "testfevent" command. It is + * used for testing the "fileevent" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestfeventCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static Tcl_Interp *interp2 = NULL; + int code; + Tcl_Channel chan; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "cmd") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd script", (char *) NULL); + return TCL_ERROR; + } + if (interp2 != (Tcl_Interp *) NULL) { + code = Tcl_GlobalEval(interp2, argv[2]); + interp->result = interp2->result; + return code; + } else { + Tcl_AppendResult(interp, + "called \"testfevent code\" before \"testfevent create\"", + (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(argv[1], "create") == 0) { + if (interp2 != NULL) { + Tcl_DeleteInterp(interp2); + } + interp2 = Tcl_CreateInterp(); + return TCL_OK; + } else if (strcmp(argv[1], "delete") == 0) { + if (interp2 != NULL) { + Tcl_DeleteInterp(interp2); + } + interp2 = NULL; + } else if (strcmp(argv[1], "share") == 0) { + if (interp2 != NULL) { + chan = Tcl_GetChannel(interp, argv[2], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(interp2, chan); + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestPanicCmd -- + * + * Calls the panic routine. + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * May exit application. + * + *---------------------------------------------------------------------- + */ + +static int +TestPanicCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *argString; + + /* + * Put the arguments into a var args structure + * Append all of the arguments together separated by spaces + */ + + argString = Tcl_Merge(argc-1, argv+1); + panic(argString); + ckfree(argString); + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TestchmodCmd -- + * + * Implements the "testchmod" cmd. Used when testing "file" + * command. The only attribute used by the Mac and Windows platforms + * is the user write flag; if this is not set, the file is + * made read-only. Otehrwise, the file is made read-write. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Changes permissions of specified files. + * + *--------------------------------------------------------------------------- + */ + +static int +TestchmodCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, mode; + char *rest; + + if (argc < 2) { + usage: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " mode file ?file ...?", (char *) NULL); + return TCL_ERROR; + } + + mode = (int) strtol(argv[1], &rest, 8); + if ((rest == argv[1]) || (*rest != '\0')) { + goto usage; + } + + for (i = 2; i < argc; i++) { + Tcl_DString buffer; + + argv[i] = Tcl_TranslateFileName(interp, argv[i], &buffer); + if (argv[i] == NULL) { + return TCL_ERROR; + } + if (chmod(argv[i], (unsigned) mode) != 0) { + Tcl_AppendResult(interp, argv[i], ": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringFree(&buffer); + } + return TCL_OK; +} + +static int +TestfileCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int force, i, j, result; + Tcl_DString error, name[2]; + + if (argc < 3) { + return TCL_ERROR; + } + + force = 0; + i = 2; + if (strcmp(argv[2], "-force") == 0) { + force = 1; + i = 3; + } + + Tcl_DStringInit(&name[0]); + Tcl_DStringInit(&name[1]); + Tcl_DStringInit(&error); + + if (argc - i > 2) { + return TCL_ERROR; + } + + for (j = i; j < argc; j++) { + argv[j] = Tcl_TranslateFileName(interp, argv[j], &name[j - i]); + if (argv[j] == NULL) { + return TCL_ERROR; + } + } + + if (strcmp(argv[1], "mv") == 0) { + result = TclpRenameFile(argv[i], argv[i + 1]); + } else if (strcmp(argv[1], "cp") == 0) { + result = TclpCopyFile(argv[i], argv[i + 1]); + } else if (strcmp(argv[1], "rm") == 0) { + result = TclpDeleteFile(argv[i]); + } else if (strcmp(argv[1], "mkdir") == 0) { + result = TclpCreateDirectory(argv[i]); + } else if (strcmp(argv[1], "cpdir") == 0) { + result = TclpCopyDirectory(argv[i], argv[i + 1], &error); + } else if (strcmp(argv[1], "rmdir") == 0) { + result = TclpRemoveDirectory(argv[i], force, &error); + } else { + result = TCL_ERROR; + goto end; + } + + if (result != TCL_OK) { + if (Tcl_DStringValue(&error)[0] != '\0') { + Tcl_AppendResult(interp, Tcl_DStringValue(&error), " ", NULL); + } + Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL); + } + + end: + Tcl_DStringFree(&error); + Tcl_DStringFree(&name[0]); + Tcl_DStringFree(&name[1]); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TestgetvarfullnameCmd -- + * + * Implements the "testgetvarfullname" cmd that is used when testing + * the Tcl_GetVariableFullName procedure. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetvarfullnameCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + char *name, *arg; + int flags = 0; + Tcl_Namespace *namespacePtr; + Tcl_CallFrame frame; + Tcl_Var variable; + int result; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name scope"); + return TCL_ERROR; + } + + name = Tcl_GetStringFromObj(objv[1], (int *) NULL); + + arg = Tcl_GetStringFromObj(objv[2], (int *) NULL); + if (strcmp(arg, "global") == 0) { + flags = TCL_GLOBAL_ONLY; + } else if (strcmp(arg, "namespace") == 0) { + flags = TCL_NAMESPACE_ONLY; + } + + /* + * This command, like any other created with Tcl_Create[Obj]Command, + * runs in the global namespace. As a "namespace-aware" command that + * needs to run in a particular namespace, it must activate that + * namespace itself. + */ + + if (flags == TCL_NAMESPACE_ONLY) { + namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var", + (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG); + if (namespacePtr == NULL) { + return TCL_ERROR; + } + result = Tcl_PushCallFrame(interp, &frame, namespacePtr, + /*isProcCallFrame*/ 0); + if (result != TCL_OK) { + return result; + } + } + + variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL, + (flags | TCL_LEAVE_ERR_MSG)); + + if (flags == TCL_NAMESPACE_ONLY) { + Tcl_PopCallFrame(interp); + } + if (variable == (Tcl_Var) NULL) { + return TCL_ERROR; + } + Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetTimesCmd -- + * + * This procedure implements the "gettimes" command. It is + * used for computing the time needed for various basic operations + * such as reading variables, allocating memory, sprintf, converting + * variables, etc. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Allocates and frees memory, sets a variable "a" in the interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +GetTimesCmd(unused, interp, argc, argv) + ClientData unused; /* Unused. */ + Tcl_Interp *interp; /* The current interpreter. */ + int argc; /* The number of arguments. */ + char **argv; /* The argument strings. */ +{ + Interp *iPtr = (Interp *) interp; + int i, n; + double timePer; + Tcl_Time start, stop; + Tcl_Obj *objPtr; + Tcl_Obj **objv; + char *s; + char newString[30]; + + /* alloc & free 100000 times */ + fprintf(stderr, "alloc & free 100000 6 word items\n"); + TclpGetTime(&start); + for (i = 0; i < 100000; i++) { + objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); + ckfree((char *) objPtr); + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000); + + /* alloc 5000 times */ + fprintf(stderr, "alloc 5000 6 word items\n"); + objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *)); + TclpGetTime(&start); + for (i = 0; i < 5000; i++) { + objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per alloc\n", timePer/5000); + + /* free 5000 times */ + fprintf(stderr, "free 5000 6 word items\n"); + TclpGetTime(&start); + for (i = 0; i < 5000; i++) { + ckfree((char *) objv[i]); + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per free\n", timePer/5000); + + /* Tcl_NewObj 5000 times */ + fprintf(stderr, "Tcl_NewObj 5000 times\n"); + TclpGetTime(&start); + for (i = 0; i < 5000; i++) { + objv[i] = Tcl_NewObj(); + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per Tcl_NewObj\n", timePer/5000); + + /* Tcl_DecrRefCount 5000 times */ + fprintf(stderr, "Tcl_DecrRefCount 5000 times\n"); + TclpGetTime(&start); + for (i = 0; i < 5000; i++) { + objPtr = objv[i]; + Tcl_DecrRefCount(objPtr); + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); + ckfree((char *) objv); + + /* TclGetStringFromObj 100000 times */ + fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); + objPtr = Tcl_NewStringObj("12345", -1); + TclpGetTime(&start); + for (i = 0; i < 100000; i++) { + (void) TclGetStringFromObj(objPtr, &n); + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n", + timePer/100000); + + /* Tcl_GetIntFromObj 100000 times */ + fprintf(stderr, "Tcl_GetIntFromObj of \"12345\" 100000 times\n"); + TclpGetTime(&start); + for (i = 0; i < 100000; i++) { + if (Tcl_GetIntFromObj(interp, objPtr, &n) != TCL_OK) { + return TCL_ERROR; + } + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per Tcl_GetIntFromObj of \"12345\"\n", + timePer/100000); + Tcl_DecrRefCount(objPtr); + + /* Tcl_GetInt 100000 times */ + fprintf(stderr, "Tcl_GetInt of \"12345\" 100000 times\n"); + TclpGetTime(&start); + for (i = 0; i < 100000; i++) { + if (Tcl_GetInt(interp, "12345", &n) != TCL_OK) { + return TCL_ERROR; + } + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per Tcl_GetInt of \"12345\"\n", + timePer/100000); + + /* sprintf 100000 times */ + fprintf(stderr, "sprintf of 12345 100000 times\n"); + TclpGetTime(&start); + for (i = 0; i < 100000; i++) { + sprintf(newString, "%d", 12345); + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per sprintf of 12345\n", + timePer/100000); + + /* hashtable lookup 100000 times */ + fprintf(stderr, "hashtable lookup of \"gettimes\" 100000 times\n"); + TclpGetTime(&start); + for (i = 0; i < 100000; i++) { + (void) Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "gettimes"); + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per hashtable lookup of \"gettimes\"\n", + timePer/100000); + + /* Tcl_SetVar 100000 times */ + fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); + TclpGetTime(&start); + for (i = 0; i < 100000; i++) { + s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); + if (s == NULL) { + return TCL_ERROR; + } + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per Tcl_SetVar of a to \"12345\"\n", + timePer/100000); + + /* Tcl_GetVar 100000 times */ + fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); + TclpGetTime(&start); + for (i = 0; i < 100000; i++) { + s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); + if (s == NULL) { + return TCL_ERROR; + } + } + TclpGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + fprintf(stderr, " %.3f usec per Tcl_GetVar of a==\"12345\"\n", + timePer/100000); + + Tcl_ResetResult(interp); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NoopCmd -- + * + * This procedure is just used to time the overhead involved in + * parsing and invoking a command. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +NoopCmd(unused, interp, argc, argv) + ClientData unused; /* Unused. */ + Tcl_Interp *interp; /* The current interpreter. */ + int argc; /* The number of arguments. */ + char **argv; /* The argument strings. */ +{ + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NoopObjCmd -- + * + * This object-based procedure is just used to time the overhead + * involved in parsing and invoking a command. + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +NoopObjCmd(unused, interp, objc, objv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestsetnoerrCmd -- + * + * Implements the "testsetnoerr" cmd that is used when testing + * the Tcl_Set/GetVar C Api without TCL_LEAVE_ERR_MSG flag + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestsetnoerrCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *value; + if (argc == 2) { + Tcl_SetResult(interp, "before get", TCL_STATIC); + value = Tcl_GetVar2(interp, argv[1], (char *) NULL, TCL_PARSE_PART1); + if (value == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, value, TCL_VOLATILE); + return TCL_OK; + } else if (argc == 3) { + char *m1 = "before set"; + char *message=Tcl_Alloc(strlen(m1)+1); + + strcpy(message,m1); + + Tcl_SetResult(interp, message, TCL_DYNAMIC); + + value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], + TCL_PARSE_PART1); + if (value == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, value, TCL_VOLATILE); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?newValue?\"", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * TeststatprocCmd -- + * + * Implements the "testTclStatProc" cmd that is used to test the + * 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TeststatprocCmd (dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TclStatProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpStat") == 0) { + proc = TclpStat; + } else if (strcmp(argv[2], "TestStatProc1") == 0) { + proc = TestStatProc1; + } else if (strcmp(argv[2], "TestStatProc2") == 0) { + proc = TestStatProc2; + } else if (strcmp(argv[2], "TestStatProc3") == 0) { + proc = TestStatProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be TclpStat, ", + "TestStatProc1, TestStatProc2, or TestStatProc3", + (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == TclpStat) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be ", + "TestStatProc1, TestStatProc2, or TestStatProc3", + (char *) NULL); + return TCL_ERROR; + } + retVal = TclStatInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclStatDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", + "must be insert or delete", (char *) NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": ", + "could not be ", argv[1], "ed", (char *) NULL); + } + + return retVal; +} + +/* Be careful in the compares in these tests, since the Macintosh puts a + * leading : in the beginning of non-absolute paths before passing them + * into the file command procedures. + */ + +static int +TestStatProc1(path, buf) + CONST char *path; + TclStat_ *buf; +{ + buf->st_size = 1234; + return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0); +} + + +static int +TestStatProc2(path, buf) + CONST char *path; + TclStat_ *buf; +{ + buf->st_size = 2345; + return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0); +} + + +static int +TestStatProc3(path, buf) + CONST char *path; + TclStat_ *buf; +{ + buf->st_size = 3456; + return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0); +} + +/* + *---------------------------------------------------------------------- + * + * TestaccessprocCmd -- + * + * Implements the "testTclAccessProc" cmd that is used to test the + * 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestaccessprocCmd (dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TclAccessProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpAccess") == 0) { + proc = TclpAccess; + } else if (strcmp(argv[2], "TestAccessProc1") == 0) { + proc = TestAccessProc1; + } else if (strcmp(argv[2], "TestAccessProc2") == 0) { + proc = TestAccessProc2; + } else if (strcmp(argv[2], "TestAccessProc3") == 0) { + proc = TestAccessProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be TclpAccess, ", + "TestAccessProc1, TestAccessProc2, or TestAccessProc3", + (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == TclpAccess) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be ", + "TestAccessProc1, TestAccessProc2, or TestAccessProc3", + (char *) NULL); + return TCL_ERROR; + } + retVal = TclAccessInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclAccessDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", + "must be insert or delete", (char *) NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": ", + "could not be ", argv[1], "ed", (char *) NULL); + } + + return retVal; +} + + +static int +TestAccessProc1(path, mode) + CONST char *path; + int mode; +{ + return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0); +} + + +static int +TestAccessProc2(path, mode) + CONST char *path; + int mode; +{ + return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0); +} + + +static int +TestAccessProc3(path, mode) + CONST char *path; + int mode; +{ + return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0); +} + +/* + *---------------------------------------------------------------------- + * + * TestopenfilechannelprocCmd -- + * + * Implements the "testTclOpenFileChannelProc" cmd that is used to test the + * 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestopenfilechannelprocCmd (dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TclOpenFileChannelProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpOpenFileChannel") == 0) { + proc = TclpOpenFileChannel; + } else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) { + proc = TestOpenFileChannelProc1; + } else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) { + proc = TestOpenFileChannelProc2; + } else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) { + proc = TestOpenFileChannelProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be TclpOpenFileChannel, ", + "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ", + "TestOpenFileChannelProc3", + (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == TclpOpenFileChannel) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be ", + "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ", + "TestOpenFileChannelProc3", + (char *) NULL); + return TCL_ERROR; + } + retVal = TclOpenFileChannelInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclOpenFileChannelDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", + "must be insert or delete", (char *) NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": ", + "could not be ", argv[1], "ed", (char *) NULL); + } + + return retVal; +} + + +static Tcl_Channel +TestOpenFileChannelProc1(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + if (!strcmp("testOpenFileChannel1%.fil", fileName)) { + return (TclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil", + modeString, permissions)); + } else { + return (NULL); + } +} + + +static Tcl_Channel +TestOpenFileChannelProc2(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + if (!strcmp("testOpenFileChannel2%.fil", fileName)) { + return (TclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil", + modeString, permissions)); + } else { + return (NULL); + } +} + + +static Tcl_Channel +TestOpenFileChannelProc3(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + if (!strcmp("testOpenFileChannel3%.fil", fileName)) { + return (TclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil", + modeString, permissions)); + } else { + return (NULL); + } +} diff --git a/tcl/generic/tclTestObj.c b/tcl/generic/tclTestObj.c new file mode 100644 index 00000000000..e8730e035d5 --- /dev/null +++ b/tcl/generic/tclTestObj.c @@ -0,0 +1,1105 @@ +/* + * tclTestObj.c -- + * + * This file contains C command procedures for the additional Tcl + * commands that are used for testing implementations of the Tcl object + * types. These commands are not normally included in Tcl + * applications; they're only used for testing. + * + * 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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * An array of Tcl_Obj pointers used in the commands that operate on or get + * the values of Tcl object-valued variables. varPtr[i] is the i-th + * variable's Tcl_Obj *. + */ + +#define NUMBER_OF_OBJECT_VARS 20 +static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS]; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp, + int varIndex)); +static int GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *indexPtr)); +static void SetVarToObj _ANSI_ARGS_((int varIndex, + Tcl_Obj *objPtr)); +int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +static int TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestconvertobjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestindexobjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestintobjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestobjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TeststringobjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); + +/* + *---------------------------------------------------------------------- + * + * TclObjTest_Init -- + * + * This procedure creates additional commands that are used to test the + * Tcl object support. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Creates and registers several new testing commands. + * + *---------------------------------------------------------------------- + */ + +int +TclObjTest_Init(interp) + Tcl_Interp *interp; +{ + register int i; + + for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { + varPtr[i] = NULL; + } + + Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestbooleanobjCmd -- + * + * This procedure implements the "testbooleanobj" command. It is used + * to test the boolean Tcl object type implementation. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * Creates and frees boolean objects, and also converts objects to + * have boolean type. + * + *---------------------------------------------------------------------- + */ + +static int +TestbooleanobjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int varIndex, boolValue, length; + char *index, *subCmd; + + if (objc < 3) { + wrongNumArgs: + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); + return TCL_ERROR; + } + + /* + * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. + */ + + index = Tcl_GetStringFromObj(objv[2], &length); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + + subCmd = Tcl_GetStringFromObj(objv[1], &length); + if (strcmp(subCmd, "set") == 0) { + if (objc != 4) { + goto wrongNumArgs; + } + if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the object currently bound to the variable with index varIndex + * has ref count 1 (i.e. the object is unshared) we can modify that + * object directly. Otherwise, if RC>1 (i.e. the object is shared), + * we must create a new object to modify/set and decrement the old + * formerly-shared object's ref count. This is "copy on write". + */ + + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetBooleanObj(varPtr[varIndex], boolValue); + } else { + SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue)); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "get") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "not") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex], + &boolValue) != TCL_OK) { + return TCL_ERROR; + } + if (!Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetBooleanObj(varPtr[varIndex], !boolValue); + } else { + SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue)); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL), + "\": must be set, get, or not", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestconvertobjCmd -- + * + * This procedure implements the "testconvertobj" command. It is used + * to test converting objects to new types. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * Converts objects to new types. + * + *---------------------------------------------------------------------- + */ + +static int +TestconvertobjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int length; + char *subCmd; + char buf[20]; + + if (objc < 3) { + wrongNumArgs: + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); + return TCL_ERROR; + } + + /* + * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. + */ + + subCmd = Tcl_GetStringFromObj(objv[1], &length); + if (strcmp(subCmd, "double") == 0) { + double d; + + if (objc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetDoubleFromObj(interp, objv[2], &d) != TCL_OK) { + return TCL_ERROR; + } + sprintf(buf, "%f", d); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL), + "\": must be double", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestdoubleobjCmd -- + * + * This procedure implements the "testdoubleobj" command. It is used + * to test the double-precision floating point Tcl object type + * implementation. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * Creates and frees double objects, and also converts objects to + * have double type. + * + *---------------------------------------------------------------------- + */ + +static int +TestdoubleobjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int varIndex, length; + double doubleValue; + char *index, *subCmd, *string; + + if (objc < 3) { + wrongNumArgs: + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); + return TCL_ERROR; + } + + /* + * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. + */ + + index = Tcl_GetStringFromObj(objv[2], &length); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + + subCmd = Tcl_GetStringFromObj(objv[1], &length); + if (strcmp(subCmd, "set") == 0) { + if (objc != 4) { + goto wrongNumArgs; + } + string = Tcl_GetStringFromObj(objv[3], &length); + if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the object currently bound to the variable with index varIndex + * has ref count 1 (i.e. the object is unshared) we can modify that + * object directly. Otherwise, if RC>1 (i.e. the object is shared), + * we must create a new object to modify/set and decrement the old + * formerly-shared object's ref count. This is "copy on write". + */ + + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetDoubleObj(varPtr[varIndex], doubleValue); + } else { + SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue)); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "get") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "mult10") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex], + &doubleValue) != TCL_OK) { + return TCL_ERROR; + } + if (!Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0)); + } else { + SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) )); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "div10") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex], + &doubleValue) != TCL_OK) { + return TCL_ERROR; + } + if (!Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0)); + } else { + SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) )); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL), + "\": must be set, get, mult10, or div10", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestindexobjCmd -- + * + * This procedure implements the "testindexobj" command. It is used to + * test the index Tcl object type implementation. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * Creates and frees int objects, and also converts objects to + * have int type. + * + *---------------------------------------------------------------------- + */ + +static int +TestindexobjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int allowAbbrev, index, index2, setError, i, dummy, result; + char **argv; + static char *tablePtr[] = {"a", "b", "check", (char *) NULL}; + + if ((objc == 3) && (strcmp(Tcl_GetStringFromObj(objv[1], &dummy), + "check") == 0)) { + /* + * This code checks to be sure that the results of + * Tcl_GetIndexFromObj are properly cached in the object and + * returned on subsequent lookups. + */ + + Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr, + "token", 0, &index); + if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) { + return TCL_ERROR; + } + objv[1]->internalRep.twoPtrValue.ptr2 = (VOID *) index2; + result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], + tablePtr, "token", 0, &index); + if (result == TCL_OK) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + } + return result; + } + + if (objc < 5) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1); + return TCL_ERROR; + } + + if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) { + return TCL_ERROR; + } + argv = (char **) ckalloc((unsigned) ((objc-3) * sizeof(char *))); + for (i = 4; i < objc; i++) { + argv[i-4] = Tcl_GetStringFromObj(objv[i], &dummy); + } + argv[objc-4] = NULL; + result = Tcl_GetIndexFromObj(setError ? interp : NULL, objv[3], + argv, "token", allowAbbrev ? 0 : TCL_EXACT, &index); + ckfree((char *) argv); + if (result == TCL_OK) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TestintobjCmd -- + * + * This procedure implements the "testintobj" command. It is used to + * test the int Tcl object type implementation. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * Creates and frees int objects, and also converts objects to + * have int type. + * + *---------------------------------------------------------------------- + */ + +static int +TestintobjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int intValue, varIndex, length, i; + long longValue; + char *index, *subCmd, *string; + + if (objc < 3) { + wrongNumArgs: + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); + return TCL_ERROR; + } + + /* + * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. + */ + + index = Tcl_GetStringFromObj(objv[2], &length); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + + subCmd = Tcl_GetStringFromObj(objv[1], &length); + if (strcmp(subCmd, "set") == 0) { + if (objc != 4) { + goto wrongNumArgs; + } + string = Tcl_GetStringFromObj(objv[3], &length); + if (Tcl_GetInt(interp, string, &i) != TCL_OK) { + return TCL_ERROR; + } + intValue = i; + + /* + * If the object currently bound to the variable with index varIndex + * has ref count 1 (i.e. the object is unshared) we can modify that + * object directly. Otherwise, if RC>1 (i.e. the object is shared), + * we must create a new object to modify/set and decrement the old + * formerly-shared object's ref count. This is "copy on write". + */ + + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetIntObj(varPtr[varIndex], intValue); + } else { + SetVarToObj(varIndex, Tcl_NewIntObj(intValue)); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */ + if (objc != 4) { + goto wrongNumArgs; + } + string = Tcl_GetStringFromObj(objv[3], &length); + if (Tcl_GetInt(interp, string, &i) != TCL_OK) { + return TCL_ERROR; + } + intValue = i; + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetIntObj(varPtr[varIndex], intValue); + } else { + SetVarToObj(varIndex, Tcl_NewIntObj(intValue)); + } + } else if (strcmp(subCmd, "setlong") == 0) { + if (objc != 4) { + goto wrongNumArgs; + } + string = Tcl_GetStringFromObj(objv[3], &length); + if (Tcl_GetInt(interp, string, &i) != TCL_OK) { + return TCL_ERROR; + } + intValue = i; + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetLongObj(varPtr[varIndex], intValue); + } else { + SetVarToObj(varIndex, Tcl_NewLongObj(intValue)); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "setmaxlong") == 0) { + long maxLong = LONG_MAX; + if (objc != 3) { + goto wrongNumArgs; + } + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetLongObj(varPtr[varIndex], maxLong); + } else { + SetVarToObj(varIndex, Tcl_NewLongObj(maxLong)); + } + } else if (strcmp(subCmd, "ismaxlong") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) { + return TCL_ERROR; + } + Tcl_AppendToObj(Tcl_GetObjResult(interp), + ((longValue == LONG_MAX)? "1" : "0"), -1); + } else if (strcmp(subCmd, "get") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "inttoobigtest") == 0) { + /* + * If long ints have more bits than ints on this platform, verify + * that Tcl_GetIntFromObj returns an error if the long int held + * in an integer object's internal representation is too large + * to fit in an int. + */ + + long maxLong = LONG_MAX; + + if (objc != 3) { + goto wrongNumArgs; + } + if (INT_MAX == LONG_MAX) { /* int is same size as long int */ + Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); + } else { + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetLongObj(varPtr[varIndex], maxLong); + } else { + SetVarToObj(varIndex, Tcl_NewLongObj(maxLong)); + } + if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); + return TCL_OK; + } + Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1); + } + } else if (strcmp(subCmd, "mult10") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, varPtr[varIndex], + &intValue) != TCL_OK) { + return TCL_ERROR; + } + if (!Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetIntObj(varPtr[varIndex], (intValue * 10)); + } else { + SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) )); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "div10") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, varPtr[varIndex], + &intValue) != TCL_OK) { + return TCL_ERROR; + } + if (!Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetIntObj(varPtr[varIndex], (intValue / 10)); + } else { + SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) )); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL), + "\": must be set, get, mult10, or div10", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestobjCmd -- + * + * This procedure implements the "testobj" command. It is used to test + * the type-independent portions of the Tcl object type implementation. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * Creates and frees objects. + * + *---------------------------------------------------------------------- + */ + +static int +TestobjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int varIndex, destIndex, i; + char *index, *subCmd, *string; + Tcl_ObjType *targetType; + char buf[20]; + int length; + + if (objc < 2) { + wrongNumArgs: + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); + return TCL_ERROR; + } + + /* + * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. + */ + + subCmd = Tcl_GetStringFromObj(objv[1], &length); + if (strcmp(subCmd, "assign") == 0) { + if (objc != 4) { + goto wrongNumArgs; + } + index = Tcl_GetStringFromObj(objv[2], &length); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[3], &length); + if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { + return TCL_ERROR; + } + SetVarToObj(destIndex, varPtr[varIndex]); + Tcl_SetObjResult(interp, varPtr[destIndex]); + } else if (strcmp(subCmd, "convert") == 0) { + char *typeName; + if (objc != 4) { + goto wrongNumArgs; + } + index = Tcl_GetStringFromObj(objv[2], &length); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + typeName = Tcl_GetStringFromObj(objv[3], &length); + if ((targetType = Tcl_GetObjType(typeName)) == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "no type ", typeName, " found", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) + != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "duplicate") == 0) { + if (objc != 4) { + goto wrongNumArgs; + } + index = Tcl_GetStringFromObj(objv[2], &length); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[3], &length); + if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { + return TCL_ERROR; + } + SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex])); + Tcl_SetObjResult(interp, varPtr[destIndex]); + } else if (strcmp(subCmd, "freeallvars") == 0) { + if (objc != 2) { + goto wrongNumArgs; + } + for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { + if (varPtr[i] != NULL) { + Tcl_DecrRefCount(varPtr[i]); + varPtr[i] = NULL; + } + } + } else if (strcmp(subCmd, "newobj") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + index = Tcl_GetStringFromObj(objv[2], &length); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + SetVarToObj(varIndex, Tcl_NewObj()); + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "refcount") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + index = Tcl_GetStringFromObj(objv[2], &length); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + sprintf(buf, "%d", varPtr[varIndex]->refCount); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + } else if (strcmp(subCmd, "type") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + index = Tcl_GetStringFromObj(objv[2], &length); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ + Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); + } else { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + varPtr[varIndex]->typePtr->name, -1); + } + } else if (strcmp(subCmd, "types") == 0) { + if (objc != 2) { + goto wrongNumArgs; + } + if (Tcl_AppendAllObjTypes(interp, Tcl_GetObjResult(interp)) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", + Tcl_GetStringFromObj(objv[1], (int *) NULL), + "\": must be assign, convert, duplicate, freeallvars, ", + "newobj, objcount, refcount, type, or types", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TeststringobjCmd -- + * + * This procedure implements the "teststringobj" command. It is used to + * test the string Tcl object type implementation. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * Creates and frees string objects, and also converts objects to + * have string type. + * + *---------------------------------------------------------------------- + */ + +static int +TeststringobjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int varIndex, option, i, length; +#define MAX_STRINGS 12 + char *index, *string, *strings[MAX_STRINGS+1]; + static char *options[] = { + "append", "appendstrings", "get", "length", "length2", + "set", "set2", "setlength", (char *) NULL + }; + + if (objc < 3) { + wrongNumArgs: + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); + return TCL_ERROR; + } + + index = Tcl_GetStringFromObj(objv[2], (int *) NULL); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option) + != TCL_OK) { + return TCL_ERROR; + } + switch (option) { + case 0: /* append */ + if (objc != 5) { + goto wrongNumArgs; + } + if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) { + return TCL_ERROR; + } + if (varPtr[varIndex] == NULL) { + SetVarToObj(varIndex, Tcl_NewObj()); + } + + /* + * If the object bound to variable "varIndex" is shared, we must + * "copy on write" and append to a copy of the object. + */ + + if (Tcl_IsShared(varPtr[varIndex])) { + SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + } + string = Tcl_GetStringFromObj(objv[3], (int *) NULL); + Tcl_AppendToObj(varPtr[varIndex], string, length); + Tcl_SetObjResult(interp, varPtr[varIndex]); + break; + case 1: /* appendstrings */ + if (objc > (MAX_STRINGS+3)) { + goto wrongNumArgs; + } + if (varPtr[varIndex] == NULL) { + SetVarToObj(varIndex, Tcl_NewObj()); + } + + /* + * If the object bound to variable "varIndex" is shared, we must + * "copy on write" and append to a copy of the object. + */ + + if (Tcl_IsShared(varPtr[varIndex])) { + SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + } + for (i = 3; i < objc; i++) { + strings[i-3] = Tcl_GetStringFromObj(objv[i], (int *) NULL); + } +#if PURIFY + for (int cou = objc - 3; cou < MAX_STRINGS; cou++) + { + strings[cou] = NULL; + } +#else + strings[objc-3] = NULL; +#endif /* PURIFY */ + + Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1], + strings[2], strings[3], strings[4], strings[5], + strings[6], strings[7], strings[8], strings[9], + strings[10], strings[11]); + Tcl_SetObjResult(interp, varPtr[varIndex]); + break; + case 2: /* get */ + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + break; + case 3: /* length */ + if (objc != 3) { + goto wrongNumArgs; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) + ? varPtr[varIndex]->length : -1); + break; + case 4: /* length2 */ + if (objc != 3) { + goto wrongNumArgs; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) + ? (int) varPtr[varIndex]->internalRep.longValue : -1); + break; + case 5: /* set */ + if (objc != 4) { + goto wrongNumArgs; + } + + /* + * If the object currently bound to the variable with index + * varIndex has ref count 1 (i.e. the object is unshared) we + * can modify that object directly. Otherwise, if RC>1 (i.e. + * the object is shared), we must create a new object to + * modify/set and decrement the old formerly-shared object's + * ref count. This is "copy on write". + */ + + string = Tcl_GetStringFromObj(objv[3], &length); + if ((varPtr[varIndex] != NULL) + && !Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetStringObj(varPtr[varIndex], string, length); + } else { + SetVarToObj(varIndex, Tcl_NewStringObj(string, length)); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + break; + case 6: /* set2 */ + if (objc != 4) { + goto wrongNumArgs; + } + SetVarToObj(varIndex, objv[3]); + break; + case 7: /* setlength */ + if (objc != 4) { + goto wrongNumArgs; + } + if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) { + return TCL_ERROR; + } + if (varPtr[varIndex] != NULL) { + Tcl_SetObjLength(varPtr[varIndex], length); + } + break; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SetVarToObj -- + * + * Utility routine to assign a Tcl_Obj* to a test variable. The + * Tcl_Obj* can be NULL. + * + * Results: + * None. + * + * Side effects: + * This routine handles ref counting details for assignment: + * i.e. the old value's ref count must be decremented (if not NULL) and + * the new one incremented (also if not NULL). + * + *---------------------------------------------------------------------- + */ + +static void +SetVarToObj(varIndex, objPtr) + int varIndex; /* Designates the assignment variable. */ + Tcl_Obj *objPtr; /* Points to object to assign to var. */ +{ + if (varPtr[varIndex] != NULL) { + Tcl_DecrRefCount(varPtr[varIndex]); + } + varPtr[varIndex] = objPtr; + if (objPtr != NULL) { + Tcl_IncrRefCount(objPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * GetVariableIndex -- + * + * Utility routine to get a test variable index from the command line. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetVariableIndex(interp, string, indexPtr) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + char *string; /* String containing a variable index + * specified as a nonnegative number less + * than NUMBER_OF_OBJECT_VARS. */ + int *indexPtr; /* Place to store converted result. */ +{ + int index; + + if (Tcl_GetInt(interp, string, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1); + return TCL_ERROR; + } + + *indexPtr = index; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CheckIfVarUnset -- + * + * Utility procedure that checks whether a test variable is readable: + * i.e., that varPtr[varIndex] is non-NULL. + * + * Results: + * 1 if the test variable is unset (NULL); 0 otherwise. + * + * Side effects: + * Sets the interpreter result to an error message if the variable is + * unset (NULL). + * + *---------------------------------------------------------------------- + */ + +static int +CheckIfVarUnset(interp, varIndex) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + int varIndex; /* Index of the test variable to check. */ +{ + if (varPtr[varIndex] == NULL) { + char buf[100]; + + sprintf(buf, "variable %d is unset (NULL)", varIndex); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + return 1; + } + return 0; +} diff --git a/tcl/generic/tclTestProcBodyObj.c b/tcl/generic/tclTestProcBodyObj.c new file mode 100644 index 00000000000..7af58230572 --- /dev/null +++ b/tcl/generic/tclTestProcBodyObj.c @@ -0,0 +1,319 @@ +/* + * tclTestProcBodyObj.c -- + * + * Implements the "procbodytest" package, which contains commands + * to test creation of Tcl procedures whose body argument is a + * Tcl_Obj of type "procbody" rather than a string. + * + * Copyright (c) 1998 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +/* + * name and version of this package + */ + +static char packageName[] = "procbodytest"; +static char packageVersion[] = "1.0"; + +/* + * Name of the commands exported by this package + */ + +static char procCommand[] = "proc"; + +/* + * this struct describes an entry in the table of command names and command + * procs + */ + +typedef struct CmdTable +{ + char *cmdName; /* command name */ + Tcl_ObjCmdProc *proc; /* command proc */ + int exportIt; /* if 1, export the command */ +} CmdTable; + +/* + * Declarations for functions defined in this file. + */ + +static int ProcBodyTestProcObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int ProcBodyTestInitInternal _ANSI_ARGS_((Tcl_Interp *interp, + int isSafe)); +static int RegisterCommand _ANSI_ARGS_((Tcl_Interp* interp, + char *namespace, CONST CmdTable *cmdTablePtr)); +int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp * interp)); +int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp * interp)); + +/* + * List of commands to create when the package is loaded; must go after the + * declarations of the enable command procedure. + */ + +static CONST CmdTable commands[] = +{ + { procCommand, ProcBodyTestProcObjCmd, 1 }, + + { 0, 0, 0 } +}; + +static CONST CmdTable safeCommands[] = +{ + { procCommand, ProcBodyTestProcObjCmd, 1 }, + + { 0, 0, 0 } +}; + +/* + *---------------------------------------------------------------------- + * + * Procbodytest_Init -- + * + * This procedure initializes the "procbodytest" package. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Procbodytest_Init(interp) + Tcl_Interp *interp; /* the Tcl interpreter for which the package + * is initialized */ +{ + return ProcBodyTestInitInternal(interp, 0); +} + +/* + *---------------------------------------------------------------------- + * + * Procbodytest_SafeInit -- + * + * This procedure initializes the "procbodytest" package. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Procbodytest_SafeInit(interp) + Tcl_Interp *interp; /* the Tcl interpreter for which the package + * is initialized */ +{ + return ProcBodyTestInitInternal(interp, 1); +} + +/* + *---------------------------------------------------------------------- + * + * RegisterCommand -- + * + * This procedure registers a command in the context of the given namespace. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int RegisterCommand(interp, namespace, cmdTablePtr) + Tcl_Interp* interp; /* the Tcl interpreter for which the + * operation is performed */ + char *namespace; /* the namespace in which the command + * is registered */ + CONST CmdTable *cmdTablePtr; /* the command to register */ +{ + char buf[128]; + + if (cmdTablePtr->exportIt) { + sprintf(buf, "namespace eval %s { namespace export %s }", + namespace, cmdTablePtr->cmdName); + if (Tcl_Eval(interp, buf) != TCL_OK) + return TCL_ERROR; + } + + sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName); + Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyTestInitInternal -- + * + * This procedure initializes the Loader package. + * The isSafe flag is 1 if the interpreter is safe, 0 otherwise. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ProcBodyTestInitInternal(interp, isSafe) + Tcl_Interp *interp; /* the Tcl interpreter for which the package + * is initialized */ + int isSafe; /* 1 if this is a safe interpreter */ +{ + CONST CmdTable *cmdTablePtr; + + cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0]; + for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) { + if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) { + return TCL_ERROR; + } + } + + return Tcl_PkgProvide(interp, packageName, packageVersion); +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyTestProcObjCmd -- + * + * Implements the "procbodytest::proc" command. Here is the command + * description: + * procbodytest::proc newName argList bodyName + * Looks up a procedure called $bodyName and, if the procedure exists, + * constructs a Tcl_Obj of type "procbody" and calls Tcl_ProcObjCmd. + * Arguments: + * newName the name of the procedure to be created + * argList the argument list for the procedure + * bodyName the name of an existing procedure from which the + * body is to be copied. + * This command can be used to trigger the branches in Tcl_ProcObjCmd that + * construct a proc from a "procbody", for example: + * proc a {x} {return $x} + * a 123 + * procbodytest::proc b {x} a + * Note the call to "a 123", which is necessary so that the Proc pointer + * for "a" is filled in by the internal compiler; this is a hack. + * + * Results: + * Returns a standard Tcl code. + * + * Side effects: + * A new procedure is created. + * Leaves an error message in the interp's result on error. + * + *---------------------------------------------------------------------- + */ + +static int +ProcBodyTestProcObjCmd (dummy, interp, objc, objv) + ClientData dummy; /* context; not used */ + Tcl_Interp *interp; /* the current interpreter */ + int objc; /* argument count */ + Tcl_Obj *CONST objv[]; /* arguments */ +{ + char *fullName; + Tcl_Command procCmd; + Command *cmdPtr; + Proc *procPtr = (Proc *) NULL; + Tcl_Obj *bodyObjPtr; + Tcl_Obj *myobjv[5]; + int result; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "newName argsList bodyName"); + return TCL_ERROR; + } + + /* + * Find the Command pointer to this procedure + */ + + fullName = Tcl_GetStringFromObj(objv[3], (int *) NULL); + procCmd = Tcl_FindCommand(interp, fullName, (Tcl_Namespace *) NULL, + TCL_LEAVE_ERR_MSG); + if (procCmd == NULL) { + return TCL_ERROR; + } + + cmdPtr = (Command *) procCmd; + + /* + * check that this is a procedure and not a builtin command: + * If a procedure, cmdPtr->objProc is either 0 or TclObjInterpProc, + * and cmdPtr->proc is either 0 or TclProcInterpProc. + * Also, the compile proc should be 0, but we don't check for that. + */ + + if (((cmdPtr->objProc != NULL) + && (cmdPtr->objProc != TclGetObjInterpProc())) + || ((cmdPtr->proc != NULL) + && (cmdPtr->proc != TclGetInterpProc()))) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", fullName, + "\" is not a Tcl procedure", (char *) NULL); + return TCL_ERROR; + } + + /* + * it is a Tcl procedure: the client data is the Proc structure + */ + + if (cmdPtr->objProc != NULL) { + procPtr = (Proc *) cmdPtr->objClientData; + } else if (cmdPtr->proc != NULL) { + procPtr = (Proc *) cmdPtr->clientData; + } + + if (procPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", fullName, + "\" does not have a Proc struct!", (char *) NULL); + return TCL_ERROR; + } + + /* + * create a new object, initialize our argument vector, call into Tcl + */ + + bodyObjPtr = TclNewProcBodyObj(procPtr); + if (bodyObjPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "failed to create a procbody object for procedure \"", + fullName, "\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_IncrRefCount(bodyObjPtr); + + myobjv[0] = objv[0]; + myobjv[1] = objv[1]; + myobjv[2] = objv[2]; + myobjv[3] = bodyObjPtr; + myobjv[4] = (Tcl_Obj *) NULL; + + result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv); + Tcl_DecrRefCount(bodyObjPtr); + + return result; +} diff --git a/tcl/generic/tclTimer.c b/tcl/generic/tclTimer.c new file mode 100644 index 00000000000..6e685a8f946 --- /dev/null +++ b/tcl/generic/tclTimer.c @@ -0,0 +1,1108 @@ +/* + * tclTimer.c -- + * + * This file provides timer event management facilities for Tcl, + * including the "after" command. + * + * Copyright (c) 1997 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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * This flag indicates whether this module has been initialized. + */ + +static int initialized = 0; + +/* + * For each timer callback that's pending there is one record of the following + * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained + * together in a list sorted by time (earliest event first). + */ + +typedef struct TimerHandler { + Tcl_Time time; /* When timer is to fire. */ + Tcl_TimerProc *proc; /* Procedure to call. */ + ClientData clientData; /* Argument to pass to proc. */ + Tcl_TimerToken token; /* Identifies handler so it can be + * deleted. */ + struct TimerHandler *nextPtr; /* Next event in queue, or NULL for + * end of queue. */ +} TimerHandler; + +static TimerHandler *firstTimerHandlerPtr = NULL; + /* First event in queue. */ +static int lastTimerId; /* Timer identifier of most recently + * created timer. */ +static int timerPending; /* 1 if a timer event is in the queue. */ + +/* + * The data structure below is used by the "after" command to remember + * the command to be executed later. All of the pending "after" commands + * for an interpreter are linked together in a list. + */ + +typedef struct AfterInfo { + struct AfterAssocData *assocPtr; + /* Pointer to the "tclAfter" assocData for + * the interp in which command will be + * executed. */ + char *command; /* Command to execute. Malloc'ed, so must + * be freed when structure is deallocated. */ + int id; /* Integer identifier for command; used to + * cancel it. */ + Tcl_TimerToken token; /* Used to cancel the "after" command. NULL + * means that the command is run as an + * idle handler rather than as a timer + * handler. NULL means this is an "after + * idle" handler rather than a + * timer handler. */ + struct AfterInfo *nextPtr; /* Next in list of all "after" commands for + * this interpreter. */ +} AfterInfo; + +/* + * One of the following structures is associated with each interpreter + * for which an "after" command has ever been invoked. A pointer to + * this structure is stored in the AssocData for the "tclAfter" key. + */ + +typedef struct AfterAssocData { + Tcl_Interp *interp; /* The interpreter for which this data is + * registered. */ + AfterInfo *firstAfterPtr; /* First in list of all "after" commands + * still pending for this interpreter, or + * NULL if none. */ +} AfterAssocData; + +/* + * There is one of the following structures for each of the + * handlers declared in a call to Tcl_DoWhenIdle. All of the + * currently-active handlers are linked together into a list. + */ + +typedef struct IdleHandler { + Tcl_IdleProc (*proc); /* Procedure to call. */ + ClientData clientData; /* Value to pass to proc. */ + int generation; /* Used to distinguish older handlers from + * recently-created ones. */ + struct IdleHandler *nextPtr;/* Next in list of active handlers. */ +} IdleHandler; + +static IdleHandler *idleList; + /* First in list of all idle handlers. */ +static IdleHandler *lastIdlePtr; + /* Last in list (or NULL for empty list). */ +static int idleGeneration; /* Used to fill in the "generation" fields + * of IdleHandler structures. Increments + * each time Tcl_DoOneEvent starts calling + * idle handlers, so that all old handlers + * can be called without calling any of the + * new ones created by old ones. */ + +/* + * Prototypes for procedures referenced only in this file: + */ + +static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void AfterProc _ANSI_ARGS_((ClientData clientData)); +static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr)); +static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr, + char *string)); +static void InitTimer _ANSI_ARGS_((void)); +static void TimerExitProc _ANSI_ARGS_((ClientData clientData)); +static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); +static void TimerCheckProc _ANSI_ARGS_((ClientData clientData, + int flags)); +static void TimerSetupProc _ANSI_ARGS_((ClientData clientData, + int flags)); + +/* + *---------------------------------------------------------------------- + * + * InitTimer -- + * + * This function initializes the timer module. + * + * Results: + * None. + * + * Side effects: + * Registers the idle and timer event sources. + * + *---------------------------------------------------------------------- + */ + +static void +InitTimer() +{ + initialized = 1; + lastTimerId = 0; + timerPending = 0; + idleGeneration = 0; + firstTimerHandlerPtr = NULL; + lastIdlePtr = NULL; + idleList = NULL; + + Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL); + Tcl_CreateExitHandler(TimerExitProc, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TimerExitProc -- + * + * This function is call at exit or unload time to remove the + * timer and idle event sources. + * + * Results: + * None. + * + * Side effects: + * Removes the timer and idle event sources. + * + *---------------------------------------------------------------------- + */ + +static void +TimerExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); + initialized = 0; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_CreateTimerHandler -- + * + * Arrange for a given procedure to be invoked at a particular + * time in the future. + * + * Results: + * The return value is a token for the timer event, which + * may be used to delete the event before it fires. + * + * Side effects: + * When milliseconds have elapsed, proc will be invoked + * exactly once. + * + *-------------------------------------------------------------- + */ + +Tcl_TimerToken +Tcl_CreateTimerHandler(milliseconds, proc, clientData) + int milliseconds; /* How many milliseconds to wait + * before invoking proc. */ + Tcl_TimerProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; + Tcl_Time time; + + if (!initialized) { + InitTimer(); + } + + timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); + + /* + * Compute when the event should fire. + */ + + TclpGetTime(&time); + timerHandlerPtr->time.sec = time.sec + milliseconds/1000; + timerHandlerPtr->time.usec = time.usec + (milliseconds%1000)*1000; + if (timerHandlerPtr->time.usec >= 1000000) { + timerHandlerPtr->time.usec -= 1000000; + timerHandlerPtr->time.sec += 1; + } + + /* + * Fill in other fields for the event. + */ + + timerHandlerPtr->proc = proc; + timerHandlerPtr->clientData = clientData; + lastTimerId++; + timerHandlerPtr->token = (Tcl_TimerToken) lastTimerId; + + /* + * Add the event to the queue in the correct position + * (ordered by event firing time). + */ + + for (tPtr2 = firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; + prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { + if ((tPtr2->time.sec > timerHandlerPtr->time.sec) + || ((tPtr2->time.sec == timerHandlerPtr->time.sec) + && (tPtr2->time.usec > timerHandlerPtr->time.usec))) { + break; + } + } + timerHandlerPtr->nextPtr = tPtr2; + if (prevPtr == NULL) { + firstTimerHandlerPtr = timerHandlerPtr; + } else { + prevPtr->nextPtr = timerHandlerPtr; + } + + TimerSetupProc(NULL, TCL_ALL_EVENTS); + return timerHandlerPtr->token; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DeleteTimerHandler -- + * + * Delete a previously-registered timer handler. + * + * Results: + * None. + * + * Side effects: + * Destroy the timer callback identified by TimerToken, + * so that its associated procedure will not be called. + * If the callback has already fired, or if the given + * token doesn't exist, then nothing happens. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DeleteTimerHandler(token) + Tcl_TimerToken token; /* Result previously returned by + * Tcl_DeleteTimerHandler. */ +{ + register TimerHandler *timerHandlerPtr, *prevPtr; + + for (timerHandlerPtr = firstTimerHandlerPtr, prevPtr = NULL; + timerHandlerPtr != NULL; prevPtr = timerHandlerPtr, + timerHandlerPtr = timerHandlerPtr->nextPtr) { + if (timerHandlerPtr->token != token) { + continue; + } + if (prevPtr == NULL) { + firstTimerHandlerPtr = timerHandlerPtr->nextPtr; + } else { + prevPtr->nextPtr = timerHandlerPtr->nextPtr; + } + ckfree((char *) timerHandlerPtr); + return; + } +} + +/* + *---------------------------------------------------------------------- + * + * TimerSetupProc -- + * + * This function is called by Tcl_DoOneEvent to setup the timer + * event source for before blocking. This routine checks both the + * idle and after timer lists. + * + * Results: + * None. + * + * Side effects: + * May update the maximum notifier block time. + * + *---------------------------------------------------------------------- + */ + +static void +TimerSetupProc(data, flags) + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ +{ + Tcl_Time blockTime; + + if (((flags & TCL_IDLE_EVENTS) && idleList) + || ((flags & TCL_TIMER_EVENTS) && timerPending)) { + /* + * There is an idle handler or a pending timer event, so just poll. + */ + + blockTime.sec = 0; + blockTime.usec = 0; + + } else if ((flags & TCL_TIMER_EVENTS) && firstTimerHandlerPtr) { + /* + * Compute the timeout for the next timer on the list. + */ + + TclpGetTime(&blockTime); + blockTime.sec = firstTimerHandlerPtr->time.sec - blockTime.sec; + blockTime.usec = firstTimerHandlerPtr->time.usec - blockTime.usec; + if (blockTime.usec < 0) { + blockTime.sec -= 1; + blockTime.usec += 1000000; + } + if (blockTime.sec < 0) { + blockTime.sec = 0; + blockTime.usec = 0; + } + } else { + return; + } + + Tcl_SetMaxBlockTime(&blockTime); +} + +/* + *---------------------------------------------------------------------- + * + * TimerCheckProc -- + * + * This function is called by Tcl_DoOneEvent to check the timer + * event source for events. This routine checks both the + * idle and after timer lists. + * + * Results: + * None. + * + * Side effects: + * May queue an event and update the maximum notifier block time. + * + *---------------------------------------------------------------------- + */ + +static void +TimerCheckProc(data, flags) + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ +{ + Tcl_Event *timerEvPtr; + Tcl_Time blockTime; + + if ((flags & TCL_TIMER_EVENTS) && firstTimerHandlerPtr) { + /* + * Compute the timeout for the next timer on the list. + */ + + TclpGetTime(&blockTime); + blockTime.sec = firstTimerHandlerPtr->time.sec - blockTime.sec; + blockTime.usec = firstTimerHandlerPtr->time.usec - blockTime.usec; + if (blockTime.usec < 0) { + blockTime.sec -= 1; + blockTime.usec += 1000000; + } + if (blockTime.sec < 0) { + blockTime.sec = 0; + blockTime.usec = 0; + } + + /* + * If the first timer has expired, stick an event on the queue. + */ + + if (blockTime.sec == 0 && blockTime.usec == 0 && !timerPending) { + timerPending = 1; + timerEvPtr = (Tcl_Event *) ckalloc(sizeof(Tcl_Event)); + timerEvPtr->proc = TimerHandlerEventProc; + Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TimerHandlerEventProc -- + * + * This procedure is called by Tcl_ServiceEvent when a timer event + * reaches the front of the event queue. This procedure handles + * the event by invoking the callbacks for all timers that are + * ready. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The only time the event isn't + * handled is if the TCL_TIMER_EVENTS flag bit isn't set. + * + * Side effects: + * Whatever the timer handler callback procedures do. + * + *---------------------------------------------------------------------- + */ + +static int +TimerHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + TimerHandler *timerHandlerPtr, **nextPtrPtr; + Tcl_Time time; + int currentTimerId; + + /* + * Do nothing if timers aren't enabled. This leaves the event on the + * queue, so we will get to it as soon as ServiceEvents() is called + * with timers enabled. + */ + + if (!(flags & TCL_TIMER_EVENTS)) { + return 0; + } + + /* + * The code below is trickier than it may look, for the following + * reasons: + * + * 1. New handlers can get added to the list while the current + * one is being processed. If new ones get added, we don't + * want to process them during this pass through the list to avoid + * starving other event sources. This is implemented using the + * token number in the handler: new handlers will have a + * newer token than any of the ones currently on the list. + * 2. The handler can call Tcl_DoOneEvent, so we have to remove + * the handler from the list before calling it. Otherwise an + * infinite loop could result. + * 3. Tcl_DeleteTimerHandler can be called to remove an element from + * the list while a handler is executing, so the list could + * change structure during the call. + * 4. Because we only fetch the current time before entering the loop, + * the only way a new timer will even be considered runnable is if + * its expiration time is within the same millisecond as the + * current time. This is fairly likely on Windows, since it has + * a course granularity clock. Since timers are placed + * on the queue in time order with the most recently created + * handler appearing after earlier ones with the same expiration + * time, we don't have to worry about newer generation timers + * appearing before later ones. + */ + + timerPending = 0; + currentTimerId = lastTimerId; + TclpGetTime(&time); + while (1) { + nextPtrPtr = &firstTimerHandlerPtr; + timerHandlerPtr = firstTimerHandlerPtr; + if (timerHandlerPtr == NULL) { + break; + } + + if ((timerHandlerPtr->time.sec > time.sec) + || ((timerHandlerPtr->time.sec == time.sec) + && (timerHandlerPtr->time.usec > time.usec))) { + break; + } + + /* + * Bail out if the next timer is of a newer generation. + */ + + if ((currentTimerId - (int)timerHandlerPtr->token) < 0) { + break; + } + + /* + * Remove the handler from the queue before invoking it, + * to avoid potential reentrancy problems. + */ + + (*nextPtrPtr) = timerHandlerPtr->nextPtr; + (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); + ckfree((char *) timerHandlerPtr); + } + TimerSetupProc(NULL, TCL_TIMER_EVENTS); + return 1; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DoWhenIdle -- + * + * Arrange for proc to be invoked the next time the system is + * idle (i.e., just before the next time that Tcl_DoOneEvent + * would have to wait for something to happen). + * + * Results: + * None. + * + * Side effects: + * Proc will eventually be called, with clientData as argument. + * See the manual entry for details. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DoWhenIdle(proc, clientData) + Tcl_IdleProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + register IdleHandler *idlePtr; + Tcl_Time blockTime; + + if (!initialized) { + InitTimer(); + } + + idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler)); + idlePtr->proc = proc; + idlePtr->clientData = clientData; + idlePtr->generation = idleGeneration; + idlePtr->nextPtr = NULL; + if (lastIdlePtr == NULL) { + idleList = idlePtr; + } else { + lastIdlePtr->nextPtr = idlePtr; + } + lastIdlePtr = idlePtr; + + blockTime.sec = 0; + blockTime.usec = 0; + Tcl_SetMaxBlockTime(&blockTime); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CancelIdleCall -- + * + * If there are any when-idle calls requested to a given procedure + * with given clientData, cancel all of them. + * + * Results: + * None. + * + * Side effects: + * If the proc/clientData combination were on the when-idle list, + * they are removed so that they will never be called. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CancelIdleCall(proc, clientData) + Tcl_IdleProc *proc; /* Procedure that was previously registered. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + register IdleHandler *idlePtr, *prevPtr; + IdleHandler *nextPtr; + + for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL; + prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) { + while ((idlePtr->proc == proc) + && (idlePtr->clientData == clientData)) { + nextPtr = idlePtr->nextPtr; + ckfree((char *) idlePtr); + idlePtr = nextPtr; + if (prevPtr == NULL) { + idleList = idlePtr; + } else { + prevPtr->nextPtr = idlePtr; + } + if (idlePtr == NULL) { + lastIdlePtr = prevPtr; + return; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclServiceIdle -- + * + * This procedure is invoked by the notifier when it becomes + * idle. It will invoke all idle handlers that are present at + * the time the call is invoked, but not those added during idle + * processing. + * + * Results: + * The return value is 1 if TclServiceIdle found something to + * do, otherwise return value is 0. + * + * Side effects: + * Invokes all pending idle handlers. + * + *---------------------------------------------------------------------- + */ + +int +TclServiceIdle() +{ + IdleHandler *idlePtr; + int oldGeneration; + Tcl_Time blockTime; + + if (idleList == NULL) { + return 0; + } + + oldGeneration = idleGeneration; + idleGeneration++; + + /* + * The code below is trickier than it may look, for the following + * reasons: + * + * 1. New handlers can get added to the list while the current + * one is being processed. If new ones get added, we don't + * want to process them during this pass through the list (want + * to check for other work to do first). This is implemented + * using the generation number in the handler: new handlers + * will have a different generation than any of the ones currently + * on the list. + * 2. The handler can call Tcl_DoOneEvent, so we have to remove + * the handler from the list before calling it. Otherwise an + * infinite loop could result. + * 3. Tcl_CancelIdleCall can be called to remove an element from + * the list while a handler is executing, so the list could + * change structure during the call. + */ + + for (idlePtr = idleList; + ((idlePtr != NULL) + && ((oldGeneration - idlePtr->generation) >= 0)); + idlePtr = idleList) { + idleList = idlePtr->nextPtr; + if (idleList == NULL) { + lastIdlePtr = NULL; + } + (*idlePtr->proc)(idlePtr->clientData); + ckfree((char *) idlePtr); + } + if (idleList) { + blockTime.sec = 0; + blockTime.usec = 0; + Tcl_SetMaxBlockTime(&blockTime); + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AfterObjCmd -- + * + * This procedure is invoked to process the "after" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_AfterObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Points to the "tclAfter" assocData for + * this interpreter, or NULL if the assocData + * hasn't been created yet.*/ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + /* + * The variable below is used to generate unique identifiers for + * after commands. This id can wrap around, which can potentially + * cause problems. However, there are not likely to be problems + * in practice, because after commands can only be requested to + * about a month in the future, and wrap-around is unlikely to + * occur in less than about 1-10 years. Thus it's unlikely that + * any old ids will still be around when wrap-around occurs. + */ + + static int nextId = 1; + int ms; + AfterInfo *afterPtr; + AfterAssocData *assocPtr = (AfterAssocData *) clientData; + Tcl_CmdInfo cmdInfo; + int length; + char *arg; + int index, result; + static char *subCmds[] = { + "cancel", "idle", "info", + (char *) NULL}; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } + + /* + * Create the "after" information associated for this interpreter, + * if it doesn't already exist. Associate it with the command too, + * so that it will be passed in as the ClientData argument in the + * future. + */ + + if (assocPtr == NULL) { + assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); + assocPtr->interp = interp; + assocPtr->firstAfterPtr = NULL; + Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, + (ClientData) assocPtr); + cmdInfo.proc = NULL; + cmdInfo.clientData = (ClientData) NULL; + cmdInfo.objProc = Tcl_AfterObjCmd; + cmdInfo.objClientData = (ClientData) assocPtr; + cmdInfo.deleteProc = NULL; + cmdInfo.deleteData = (ClientData) assocPtr; + Tcl_SetCommandInfo(interp, Tcl_GetStringFromObj(objv[0], &length), + &cmdInfo); + } + + /* + * First lets see if the command was passed a number as the first argument. + */ + + arg = Tcl_GetStringFromObj(objv[1], &length); + if (isdigit(UCHAR(arg[0]))) { + if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) { + return TCL_ERROR; + } + if (ms < 0) { + ms = 0; + } + if (objc == 2) { + Tcl_Sleep(ms); + return TCL_OK; + } + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr->assocPtr = assocPtr; + if (objc == 3) { + arg = Tcl_GetStringFromObj(objv[2], &length); + afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); + strcpy(afterPtr->command, arg); + } else { + Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2); + arg = Tcl_GetStringFromObj(objPtr, &length); + afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); + strcpy(afterPtr->command, arg); + Tcl_DecrRefCount(objPtr); + } + afterPtr->id = nextId; + nextId += 1; + afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, + (ClientData) afterPtr); + afterPtr->nextPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr; + sprintf(interp->result, "after#%d", afterPtr->id); + return TCL_OK; + } + + /* + * If it's not a number it must be a subcommand. + */ + result = Tcl_GetIndexFromObj(NULL, objv[1], subCmds, "option", + 0, (int *) &index); + if (result != TCL_OK) { + Tcl_AppendResult(interp, "bad argument \"", arg, + "\": must be cancel, idle, info, or a number", + (char *) NULL); + return TCL_ERROR; + } + + switch (index) { + case 0: /* cancel */ + { + char *arg; + Tcl_Obj *objPtr = NULL; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "id|command"); + return TCL_ERROR; + } + if (objc == 3) { + arg = Tcl_GetStringFromObj(objv[2], &length); + } else { + objPtr = Tcl_ConcatObj(objc-2, objv+2);; + arg = Tcl_GetStringFromObj(objPtr, &length); + } + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (strcmp(afterPtr->command, arg) == 0) { + break; + } + } + if (afterPtr == NULL) { + afterPtr = GetAfterEvent(assocPtr, arg); + } + if (objPtr != NULL) { + Tcl_DecrRefCount(objPtr); + } + if (afterPtr != NULL) { + if (afterPtr->token != NULL) { + Tcl_DeleteTimerHandler(afterPtr->token); + } else { + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + } + FreeAfterPtr(afterPtr); + } + break; + } + case 1: /* idle */ + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "script script ..."); + return TCL_ERROR; + } + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr->assocPtr = assocPtr; + if (objc == 3) { + arg = Tcl_GetStringFromObj(objv[2], &length); + afterPtr->command = (char *) ckalloc((unsigned) length + 1); + strcpy(afterPtr->command, arg); + } else { + Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2);; + arg = Tcl_GetStringFromObj(objPtr, &length); + afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); + strcpy(afterPtr->command, arg); + Tcl_DecrRefCount(objPtr); + } + afterPtr->id = nextId; + nextId += 1; + afterPtr->token = NULL; + afterPtr->nextPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr; + Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); + sprintf(interp->result, "after#%d", afterPtr->id); + break; + case 2: /* info */ + if (objc == 2) { + char buffer[30]; + + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (assocPtr->interp == interp) { + sprintf(buffer, "after#%d", afterPtr->id); + Tcl_AppendElement(interp, buffer); + } + } + return TCL_OK; + } + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?id?"); + return TCL_ERROR; + } + arg = Tcl_GetStringFromObj(objv[2], &length); + afterPtr = GetAfterEvent(assocPtr, arg); + if (afterPtr == NULL) { + Tcl_AppendResult(interp, "event \"", arg, + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, afterPtr->command); + Tcl_AppendElement(interp, + (afterPtr->token == NULL) ? "idle" : "timer"); + break; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetAfterEvent -- + * + * This procedure parses an "after" id such as "after#4" and + * returns a pointer to the AfterInfo structure. + * + * Results: + * The return value is either a pointer to an AfterInfo structure, + * if one is found that corresponds to "string" and is for interp, + * or NULL if no corresponding after event can be found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static AfterInfo * +GetAfterEvent(assocPtr, string) + AfterAssocData *assocPtr; /* Points to "after"-related information for + * this interpreter. */ + char *string; /* Textual identifier for after event, such + * as "after#6". */ +{ + AfterInfo *afterPtr; + int id; + char *end; + + if (strncmp(string, "after#", 6) != 0) { + return NULL; + } + string += 6; + id = strtoul(string, &end, 10); + if ((end == string) || (*end != 0)) { + return NULL; + } + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (afterPtr->id == id) { + return afterPtr; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * AfterProc -- + * + * Timer callback to execute commands registered with the + * "after" command. + * + * Results: + * None. + * + * Side effects: + * Executes whatever command was specified. If the command + * returns an error, then the command "bgerror" is invoked + * to process the error; if bgerror fails then information + * about the error is output on stderr. + * + *---------------------------------------------------------------------- + */ + +static void +AfterProc(clientData) + ClientData clientData; /* Describes command to execute. */ +{ + AfterInfo *afterPtr = (AfterInfo *) clientData; + AfterAssocData *assocPtr = afterPtr->assocPtr; + AfterInfo *prevPtr; + int result; + Tcl_Interp *interp; + + /* + * First remove the callback from our list of callbacks; otherwise + * someone could delete the callback while it's being executed, which + * could cause a core dump. + */ + + if (assocPtr->firstAfterPtr == afterPtr) { + assocPtr->firstAfterPtr = afterPtr->nextPtr; + } else { + for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = afterPtr->nextPtr; + } + + /* + * Execute the callback. + */ + + interp = assocPtr->interp; + Tcl_Preserve((ClientData) interp); + result = Tcl_GlobalEval(interp, afterPtr->command); + if (result != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); + Tcl_BackgroundError(interp); + } + Tcl_Release((ClientData) interp); + + /* + * Free the memory for the callback. + */ + + ckfree(afterPtr->command); + ckfree((char *) afterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * FreeAfterPtr -- + * + * This procedure removes an "after" command from the list of + * those that are pending and frees its resources. This procedure + * does *not* cancel the timer handler; if that's needed, the + * caller must do it. + * + * Results: + * None. + * + * Side effects: + * The memory associated with afterPtr is released. + * + *---------------------------------------------------------------------- + */ + +static void +FreeAfterPtr(afterPtr) + AfterInfo *afterPtr; /* Command to be deleted. */ +{ + AfterInfo *prevPtr; + AfterAssocData *assocPtr = afterPtr->assocPtr; + + if (assocPtr->firstAfterPtr == afterPtr) { + assocPtr->firstAfterPtr = afterPtr->nextPtr; + } else { + for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = afterPtr->nextPtr; + } + ckfree(afterPtr->command); + ckfree((char *) afterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * AfterCleanupProc -- + * + * This procedure is invoked whenever an interpreter is deleted + * to cleanup the AssocData for "tclAfter". + * + * Results: + * None. + * + * Side effects: + * After commands are removed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +AfterCleanupProc(clientData, interp) + ClientData clientData; /* Points to AfterAssocData for the + * interpreter. */ + Tcl_Interp *interp; /* Interpreter that is being deleted. */ +{ + AfterAssocData *assocPtr = (AfterAssocData *) clientData; + AfterInfo *afterPtr; + + while (assocPtr->firstAfterPtr != NULL) { + afterPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr->nextPtr; + if (afterPtr->token != NULL) { + Tcl_DeleteTimerHandler(afterPtr->token); + } else { + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + } + ckfree(afterPtr->command); + ckfree((char *) afterPtr); + } + ckfree((char *) assocPtr); +} diff --git a/tcl/generic/tclUtil.c b/tcl/generic/tclUtil.c new file mode 100644 index 00000000000..ef60a9d4755 --- /dev/null +++ b/tcl/generic/tclUtil.c @@ -0,0 +1,2843 @@ +/* + * tclUtil.c -- + * + * This file contains utility procedures that are used by many Tcl + * commands. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following variable holds the full path name of the binary + * from which this application was executed, or NULL if it isn't + * know. The value of the variable is set by the procedure + * Tcl_FindExecutable. The storage space is dynamically allocated. + */ + +char *tclExecutableName = NULL; + +/* + * The following values are used in the flags returned by Tcl_ScanElement + * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also + * defined in tcl.h; make sure its value doesn't overlap with any of the + * values below. + * + * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in + * braces (e.g. it contains unmatched braces, + * or ends in a backslash character, or user + * just doesn't want braces); handle all + * special characters by adding backslashes. + * USE_BRACES - 1 means the string contains a special + * character that can be handled simply by + * enclosing the entire argument in braces. + * BRACES_UNMATCHED - 1 means that braces aren't properly matched + * in the argument. + */ + +#define USE_BRACES 2 +#define BRACES_UNMATCHED 4 + +/* + * The following values determine the precision used when converting + * floating-point values to strings. This information is linked to all + * of the tcl_precision variables in all interpreters via the procedure + * TclPrecTraceProc. + * + * NOTE: these variables are not thread-safe. + */ + +static char precisionString[10] = "12"; + /* The string value of all the tcl_precision + * variables. */ +static char precisionFormat[10] = "%.12g"; + /* The format string actually used in calls + * to sprintf. */ + + +/* + * Function prototypes for local procedures in this file: + */ + +static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, + int newSpace)); + +/* + *---------------------------------------------------------------------- + * + * TclFindElement -- + * + * Given a pointer into a Tcl list, locate the first (or next) + * element in the list. + * + * Results: + * The return value is normally TCL_OK, which means that the + * element was successfully located. If TCL_ERROR is returned + * it means that list didn't have proper list structure; + * interp->result contains a more detailed error message. + * + * If TCL_OK is returned, then *elementPtr will be set to point to the + * first element of list, and *nextPtr will be set to point to the + * character just after any white space following the last character + * that's part of the element. If this is the last argument in the + * list, then *nextPtr will point just after the last character in the + * list (i.e., at the character at list+listLength). If sizePtr is + * non-NULL, *sizePtr is filled in with the number of characters in the + * element. If the element is in braces, then *elementPtr will point + * to the character after the opening brace and *sizePtr will not + * include either of the braces. If there isn't an element in the list, + * *sizePtr will be zero, and both *elementPtr and *termPtr will point + * just after the last character in the list. Note: this procedure does + * NOT collapse backslash sequences. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, + bracePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left + * after errors. */ + char *list; /* Points to the first byte of a string + * containing a Tcl list with zero or more + * elements (possibly in braces). */ + int listLength; /* Number of bytes in the list's string. */ + char **elementPtr; /* Where to put address of first significant + * character in first element of list. */ + char **nextPtr; /* Fill in with location of character just + * after all white space following end of + * argument (next arg or end of list). */ + int *sizePtr; /* If non-zero, fill in with size of + * element. */ + int *bracePtr; /* If non-zero, fill in with non-zero/zero + * to indicate that arg was/wasn't + * in braces. */ +{ + char *p = list; + char *elemStart; /* Points to first byte of first element. */ + char *limit; /* Points just after list's last byte. */ + int openBraces = 0; /* Brace nesting level during parse. */ + int inQuotes = 0; + int size = 0; /* Init. avoids compiler warning. */ + int numChars; + char *p2; + + /* + * Skim off leading white space and check for an opening brace or + * quote. We treat embedded NULLs in the list as bytes belonging to + * a list element. Note: use of "isascii" below and elsewhere in this + * procedure is a temporary hack (7/27/90) because Mx uses characters + * with the high-order bit set for some things. This should probably + * be changed back eventually, or all of Tcl should call isascii. + */ + + limit = (list + listLength); + while ((p < limit) && (isspace(UCHAR(*p)))) { + p++; + } + if (p == limit) { /* no element found */ + elemStart = limit; + goto done; + } + + if (*p == '{') { + openBraces = 1; + p++; + } else if (*p == '"') { + inQuotes = 1; + p++; + } + elemStart = p; + if (bracePtr != 0) { + *bracePtr = openBraces; + } + + /* + * Find element's end (a space, close brace, or the end of the string). + */ + + while (p < limit) { + switch (*p) { + + /* + * Open brace: don't treat specially unless the element is in + * braces. In this case, keep a nesting count. + */ + + case '{': + if (openBraces != 0) { + openBraces++; + } + break; + + /* + * Close brace: if element is in braces, keep nesting count and + * quit when the last close brace is seen. + */ + + case '}': + if (openBraces > 1) { + openBraces--; + } else if (openBraces == 1) { + size = (p - elemStart); + p++; + if ((p >= limit) || isspace(UCHAR(*p))) { + goto done; + } + + /* + * Garbage after the closing brace; return an error. + */ + + if (interp != NULL) { + char buf[100]; + + p2 = p; + while ((p2 < limit) && (!isspace(UCHAR(*p2))) + && (p2 < p+20)) { + p2++; + } + sprintf(buf, + "list element in braces followed by \"%.*s\" instead of space", + (int) (p2-p), p); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } + return TCL_ERROR; + } + break; + + /* + * Backslash: skip over everything up to the end of the + * backslash sequence. + */ + + case '\\': { + (void) Tcl_Backslash(p, &numChars); + p += (numChars - 1); + break; + } + + /* + * Space: ignore if element is in braces or quotes; otherwise + * terminate element. + */ + + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + if ((openBraces == 0) && !inQuotes) { + size = (p - elemStart); + goto done; + } + break; + + /* + * Double-quote: if element is in quotes then terminate it. + */ + + case '"': + if (inQuotes) { + size = (p - elemStart); + p++; + if ((p >= limit) || isspace(UCHAR(*p))) { + goto done; + } + + /* + * Garbage after the closing quote; return an error. + */ + + if (interp != NULL) { + char buf[100]; + + p2 = p; + while ((p2 < limit) && (!isspace(UCHAR(*p2))) + && (p2 < p+20)) { + p2++; + } + sprintf(buf, + "list element in quotes followed by \"%.*s\" %s", + (int) (p2-p), p, "instead of space"); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } + return TCL_ERROR; + } + break; + } + p++; + } + + + /* + * End of list: terminate element. + */ + + if (p == limit) { + if (openBraces != 0) { + if (interp != NULL) { + Tcl_SetResult(interp, "unmatched open brace in list", + TCL_STATIC); + } + return TCL_ERROR; + } else if (inQuotes) { + if (interp != NULL) { + Tcl_SetResult(interp, "unmatched open quote in list", + TCL_STATIC); + } + return TCL_ERROR; + } + size = (p - elemStart); + } + + done: + while ((p < limit) && (isspace(UCHAR(*p)))) { + p++; + } + *elementPtr = elemStart; + *nextPtr = p; + if (sizePtr != 0) { + *sizePtr = size; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCopyAndCollapse -- + * + * Copy a string and eliminate any backslashes that aren't in braces. + * + * Results: + * There is no return value. Count characters get copied from src to + * dst. Along the way, if backslash sequences are found outside braces, + * the backslashes are eliminated in the copy. After scanning count + * chars from source, a null character is placed at the end of dst. + * Returns the number of characters that got copied. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclCopyAndCollapse(count, src, dst) + int count; /* Number of characters to copy from src. */ + char *src; /* Copy from here... */ + char *dst; /* ... to here. */ +{ + char c; + int numRead; + int newCount = 0; + + for (c = *src; count > 0; src++, c = *src, count--) { + if (c == '\\') { + *dst = Tcl_Backslash(src, &numRead); + dst++; + src += numRead-1; + count -= numRead-1; + newCount++; + } else { + *dst = c; + dst++; + newCount++; + } + } + *dst = 0; + return newCount; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SplitList -- + * + * Splits a list up into its constituent fields. + * + * Results + * The return value is normally TCL_OK, which means that + * the list was successfully split up. If TCL_ERROR is + * returned, it means that "list" didn't have proper list + * structure; interp->result will contain a more detailed + * error message. + * + * *argvPtr will be filled in with the address of an array + * whose elements point to the elements of list, in order. + * *argcPtr will get filled in with the number of valid elements + * in the array. A single block of memory is dynamically allocated + * to hold both the argv array and a copy of the list (with + * backslashes and braces removed in the standard way). + * The caller must eventually free this memory by calling free() + * on *argvPtr. Note: *argvPtr and *argcPtr are only modified + * if the procedure returns normally. + * + * Side effects: + * Memory is allocated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SplitList(interp, list, argcPtr, argvPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, no error message is left. */ + char *list; /* Pointer to string with list structure. */ + int *argcPtr; /* Pointer to location to fill in with + * the number of elements in the list. */ + char ***argvPtr; /* Pointer to place to store pointer to + * array of pointers to list elements. */ +{ + char **argv; + char *p; + int length, size, i, result, elSize, brace; + char *element; + + /* + * Figure out how much space to allocate. There must be enough + * space for both the array of pointers and also for a copy of + * the list. To estimate the number of pointers needed, count + * the number of space characters in the list. + */ + + for (size = 1, p = list; *p != 0; p++) { + if (isspace(UCHAR(*p))) { + size++; + } + } + size++; /* Leave space for final NULL pointer. */ + argv = (char **) ckalloc((unsigned) + ((size * sizeof(char *)) + (p - list) + 1)); + length = strlen(list); + for (i = 0, p = ((char *) argv) + size*sizeof(char *); + *list != 0; i++) { + char *prevList = list; + + result = TclFindElement(interp, list, length, &element, + &list, &elSize, &brace); + length -= (list - prevList); + if (result != TCL_OK) { + ckfree((char *) argv); + return result; + } + if (*element == 0) { + break; + } + if (i >= size) { + ckfree((char *) argv); + if (interp != NULL) { + Tcl_SetResult(interp, "internal error in Tcl_SplitList", + TCL_STATIC); + } + return TCL_ERROR; + } + argv[i] = p; + if (brace) { + memcpy((VOID *) p, (VOID *) element, (size_t) elSize); + p += elSize; + *p = 0; + p++; + } else { + TclCopyAndCollapse(elSize, element, p); + p += elSize+1; + } + } + + argv[i] = NULL; + *argvPtr = argv; + *argcPtr = i; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ScanElement -- + * + * This procedure is a companion procedure to Tcl_ConvertElement. + * It scans a string to see what needs to be done to it (e.g. add + * backslashes or enclosing braces) to make the string into a + * valid Tcl list element. + * + * Results: + * The return value is an overestimate of the number of characters + * that will be needed by Tcl_ConvertElement to produce a valid + * list element from string. The word at *flagPtr is filled in + * with a value needed by Tcl_ConvertElement when doing the actual + * conversion. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ScanElement(string, flagPtr) + CONST char *string; /* String to convert to Tcl list element. */ + int *flagPtr; /* Where to store information to guide + * Tcl_ConvertCountedElement. */ +{ + return Tcl_ScanCountedElement(string, -1, flagPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ScanCountedElement -- + * + * This procedure is a companion procedure to + * Tcl_ConvertCountedElement. It scans a string to see what + * needs to be done to it (e.g. add backslashes or enclosing + * braces) to make the string into a valid Tcl list element. + * If length is -1, then the string is scanned up to the first + * null byte. + * + * Results: + * The return value is an overestimate of the number of characters + * that will be needed by Tcl_ConvertCountedElement to produce a + * valid list element from string. The word at *flagPtr is + * filled in with a value needed by Tcl_ConvertCountedElement + * when doing the actual conversion. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ScanCountedElement(string, length, flagPtr) + CONST char *string; /* String to convert to Tcl list element. */ + int length; /* Number of bytes in string, or -1. */ + int *flagPtr; /* Where to store information to guide + * Tcl_ConvertElement. */ +{ + int flags, nestingLevel; + CONST char *p, *lastChar; + + /* + * This procedure and Tcl_ConvertElement together do two things: + * + * 1. They produce a proper list, one that will yield back the + * argument strings when evaluated or when disassembled with + * Tcl_SplitList. This is the most important thing. + * + * 2. They try to produce legible output, which means minimizing the + * use of backslashes (using braces instead). However, there are + * some situations where backslashes must be used (e.g. an element + * like "{abc": the leading brace will have to be backslashed. + * For each element, one of three things must be done: + * + * (a) Use the element as-is (it doesn't contain any special + * characters). This is the most desirable option. + * + * (b) Enclose the element in braces, but leave the contents alone. + * This happens if the element contains embedded space, or if it + * contains characters with special interpretation ($, [, ;, or \), + * or if it starts with a brace or double-quote, or if there are + * no characters in the element. + * + * (c) Don't enclose the element in braces, but add backslashes to + * prevent special interpretation of special characters. This is a + * last resort used when the argument would normally fall under case + * (b) but contains unmatched braces. It also occurs if the last + * character of the argument is a backslash or if the element contains + * a backslash followed by newline. + * + * The procedure figures out how many bytes will be needed to store + * the result (actually, it overestimates). It also collects information + * about the element in the form of a flags word. + * + * Note: list elements produced by this procedure and + * Tcl_ConvertCountedElement must have the property that they can be + * enclosing in curly braces to make sub-lists. This means, for + * example, that we must not leave unmatched curly braces in the + * resulting list element. This property is necessary in order for + * procedures like Tcl_DStringStartSublist to work. + */ + + nestingLevel = 0; + flags = 0; + if (string == NULL) { + string = ""; + } + if (length == -1) { + length = strlen(string); + } + lastChar = string + length; + p = string; + if ((p == lastChar) || (*p == '{') || (*p == '"')) { + flags |= USE_BRACES; + } + for ( ; p != lastChar; p++) { + switch (*p) { + case '{': + nestingLevel++; + break; + case '}': + nestingLevel--; + if (nestingLevel < 0) { + flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; + } + break; + case '[': + case '$': + case ';': + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + flags |= USE_BRACES; + break; + case '\\': + if ((p+1 == lastChar) || (p[1] == '\n')) { + flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; + } else { + int size; + + (void) Tcl_Backslash(p, &size); + p += size-1; + flags |= USE_BRACES; + } + break; + } + } + if (nestingLevel != 0) { + flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; + } + *flagPtr = flags; + + /* + * Allow enough space to backslash every character plus leave + * two spaces for braces. + */ + + return 2*(p-string) + 2; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConvertElement -- + * + * This is a companion procedure to Tcl_ScanElement. Given + * the information produced by Tcl_ScanElement, this procedure + * converts a string to a list element equal to that string. + * + * Results: + * Information is copied to *dst in the form of a list element + * identical to src (i.e. if Tcl_SplitList is applied to dst it + * will produce a string identical to src). The return value is + * a count of the number of characters copied (not including the + * terminating NULL character). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ConvertElement(src, dst, flags) + CONST char *src; /* Source information for list element. */ + char *dst; /* Place to put list-ified element. */ + int flags; /* Flags produced by Tcl_ScanElement. */ +{ + return Tcl_ConvertCountedElement(src, -1, dst, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConvertCountedElement -- + * + * This is a companion procedure to Tcl_ScanCountedElement. Given + * the information produced by Tcl_ScanCountedElement, this + * procedure converts a string to a list element equal to that + * string. + * + * Results: + * Information is copied to *dst in the form of a list element + * identical to src (i.e. if Tcl_SplitList is applied to dst it + * will produce a string identical to src). The return value is + * a count of the number of characters copied (not including the + * terminating NULL character). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ConvertCountedElement(src, length, dst, flags) + CONST char *src; /* Source information for list element. */ + int length; /* Number of bytes in src, or -1. */ + char *dst; /* Place to put list-ified element. */ + int flags; /* Flags produced by Tcl_ScanElement. */ +{ + char *p = dst; + CONST char *lastChar; + + /* + * See the comment block at the beginning of the Tcl_ScanElement + * code for details of how this works. + */ + + if (src && length == -1) { + length = strlen(src); + } + if ((src == NULL) || (length == 0)) { + p[0] = '{'; + p[1] = '}'; + p[2] = 0; + return 2; + } + lastChar = src + length; + if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { + *p = '{'; + p++; + for ( ; src != lastChar; src++, p++) { + *p = *src; + } + *p = '}'; + p++; + } else { + if (*src == '{') { + /* + * Can't have a leading brace unless the whole element is + * enclosed in braces. Add a backslash before the brace. + * Furthermore, this may destroy the balance between open + * and close braces, so set BRACES_UNMATCHED. + */ + + p[0] = '\\'; + p[1] = '{'; + p += 2; + src++; + flags |= BRACES_UNMATCHED; + } + for (; src != lastChar; src++) { + switch (*src) { + case ']': + case '[': + case '$': + case ';': + case ' ': + case '\\': + case '"': + *p = '\\'; + p++; + break; + case '{': + case '}': + /* + * It may not seem necessary to backslash braces, but + * it is. The reason for this is that the resulting + * list element may actually be an element of a sub-list + * enclosed in braces (e.g. if Tcl_DStringStartSublist + * has been invoked), so there may be a brace mismatch + * if the braces aren't backslashed. + */ + + if (flags & BRACES_UNMATCHED) { + *p = '\\'; + p++; + } + break; + case '\f': + *p = '\\'; + p++; + *p = 'f'; + p++; + continue; + case '\n': + *p = '\\'; + p++; + *p = 'n'; + p++; + continue; + case '\r': + *p = '\\'; + p++; + *p = 'r'; + p++; + continue; + case '\t': + *p = '\\'; + p++; + *p = 't'; + p++; + continue; + case '\v': + *p = '\\'; + p++; + *p = 'v'; + p++; + continue; + } + *p = *src; + p++; + } + } + *p = '\0'; + return p-dst; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Merge -- + * + * Given a collection of strings, merge them together into a + * single string that has proper Tcl list structured (i.e. + * Tcl_SplitList may be used to retrieve strings equal to the + * original elements, and Tcl_Eval will parse the string back + * into its original elements). + * + * Results: + * The return value is the address of a dynamically-allocated + * string containing the merged list. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Merge(argc, argv) + int argc; /* How many strings to merge. */ + char **argv; /* Array of string values. */ +{ +# define LOCAL_SIZE 20 + int localFlags[LOCAL_SIZE], *flagPtr; + int numChars; + char *result; + char *dst; + int i; + + /* + * Pass 1: estimate space, gather flags. + */ + + if (argc <= LOCAL_SIZE) { + flagPtr = localFlags; + } else { + flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); + } + numChars = 1; + for (i = 0; i < argc; i++) { + numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; + } + + /* + * Pass two: copy into the result area. + */ + + result = (char *) ckalloc((unsigned) numChars); + dst = result; + for (i = 0; i < argc; i++) { + numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); + dst += numChars; + *dst = ' '; + dst++; + } + if (dst == result) { + *dst = 0; + } else { + dst[-1] = 0; + } + + if (flagPtr != localFlags) { + ckfree((char *) flagPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Concat -- + * + * Concatenate a set of strings into a single large string. + * + * Results: + * The return value is dynamically-allocated string containing + * a concatenation of all the strings in argv, with spaces between + * the original argv elements. + * + * Side effects: + * Memory is allocated for the result; the caller is responsible + * for freeing the memory. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Concat(argc, argv) + int argc; /* Number of strings to concatenate. */ + char **argv; /* Array of strings to concatenate. */ +{ + int totalSize, i; + char *p; + char *result; + + for (totalSize = 1, i = 0; i < argc; i++) { + totalSize += strlen(argv[i]) + 1; + } + result = (char *) ckalloc((unsigned) totalSize); + if (argc == 0) { + *result = '\0'; + return result; + } + for (p = result, i = 0; i < argc; i++) { + char *element; + int length; + + /* + * Clip white space off the front and back of the string + * to generate a neater result, and ignore any empty + * elements. + */ + + element = argv[i]; + while (isspace(UCHAR(*element))) { + element++; + } + for (length = strlen(element); + (length > 0) && (isspace(UCHAR(element[length-1]))) + && ((length < 2) || (element[length-2] != '\\')); + length--) { + /* Null loop body. */ + } + if (length == 0) { + continue; + } + memcpy((VOID *) p, (VOID *) element, (size_t) length); + p += length; + *p = ' '; + p++; + } + if (p != result) { + p[-1] = 0; + } else { + *p = 0; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConcatObj -- + * + * Concatenate the strings from a set of objects into a single string + * object with spaces between the original strings. + * + * Results: + * The return value is a new string object containing a concatenation + * of the strings in objv. Its ref count is zero. + * + * Side effects: + * A new object is created. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ConcatObj(objc, objv) + int objc; /* Number of objects to concatenate. */ + Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */ +{ + int allocSize, finalSize, length, elemLength, i; + char *p; + char *element; + char *concatStr; + Tcl_Obj *objPtr; + + allocSize = 0; + for (i = 0; i < objc; i++) { + objPtr = objv[i]; + element = TclGetStringFromObj(objPtr, &length); + if ((element != NULL) && (length > 0)) { + allocSize += (length + 1); + } + } + if (allocSize == 0) { + allocSize = 1; /* enough for the NULL byte at end */ + } + + /* + * Allocate storage for the concatenated result. Note that allocSize + * is one more than the total number of characters, and so includes + * room for the terminating NULL byte. + */ + + concatStr = (char *) ckalloc((unsigned) allocSize); + + /* + * Now concatenate the elements. Clip white space off the front and back + * to generate a neater result, and ignore any empty elements. Also put + * a null byte at the end. + */ + + finalSize = 0; + if (objc == 0) { + *concatStr = '\0'; + } else { + p = concatStr; + for (i = 0; i < objc; i++) { + objPtr = objv[i]; + element = TclGetStringFromObj(objPtr, &elemLength); + while ((elemLength > 0) && (isspace(UCHAR(*element)))) { + element++; + elemLength--; + } + + /* + * Trim trailing white space. But, be careful not to trim + * a space character if it is preceded by a backslash: in + * this case it could be significant. + */ + + while ((elemLength > 0) + && isspace(UCHAR(element[elemLength-1])) + && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { + elemLength--; + } + if (elemLength == 0) { + continue; /* nothing left of this element */ + } + memcpy((VOID *) p, (VOID *) element, (size_t) elemLength); + p += elemLength; + *p = ' '; + p++; + finalSize += (elemLength + 1); + } + if (p != concatStr) { + p[-1] = 0; + finalSize -= 1; /* we overwrote the final ' ' */ + } else { + *p = 0; + } + } + + TclNewObj(objPtr); + objPtr->bytes = concatStr; + objPtr->length = finalSize; + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StringMatch -- + * + * See if a particular string matches a particular pattern. + * + * Results: + * The return value is 1 if string matches pattern, and + * 0 otherwise. The matching operation permits the following + * special characters in the pattern: *?\[] (see the manual + * entry for details on what these mean). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_StringMatch(string, pattern) + char *string; /* String. */ + char *pattern; /* Pattern, which may contain special + * characters. */ +{ + char c2; + + while (1) { + /* See if we're at the end of both the pattern and the string. + * If so, we succeeded. If we're at the end of the pattern + * but not at the end of the string, we failed. + */ + + if (*pattern == 0) { + if (*string == 0) { + return 1; + } else { + return 0; + } + } + if ((*string == 0) && (*pattern != '*')) { + return 0; + } + + /* Check for a "*" as the next pattern character. It matches + * any substring. We handle this by calling ourselves + * recursively for each postfix of string, until either we + * match or we reach the end of the string. + */ + + if (*pattern == '*') { + pattern += 1; + if (*pattern == 0) { + return 1; + } + while (1) { + if (Tcl_StringMatch(string, pattern)) { + return 1; + } + if (*string == 0) { + return 0; + } + string += 1; + } + } + + /* Check for a "?" as the next pattern character. It matches + * any single character. + */ + + if (*pattern == '?') { + goto thisCharOK; + } + + /* Check for a "[" as the next pattern character. It is followed + * by a list of characters that are acceptable, or by a range + * (two characters separated by "-"). + */ + + if (*pattern == '[') { + pattern += 1; + while (1) { + if ((*pattern == ']') || (*pattern == 0)) { + return 0; + } + if (*pattern == *string) { + break; + } + if (pattern[1] == '-') { + c2 = pattern[2]; + if (c2 == 0) { + return 0; + } + if ((*pattern <= *string) && (c2 >= *string)) { + break; + } + if ((*pattern >= *string) && (c2 <= *string)) { + break; + } + pattern += 2; + } + pattern += 1; + } + while (*pattern != ']') { + if (*pattern == 0) { + pattern--; + break; + } + pattern += 1; + } + goto thisCharOK; + } + + /* If the next pattern character is '/', just strip off the '/' + * so we do exact matching on the character that follows. + */ + + if (*pattern == '\\') { + pattern += 1; + if (*pattern == 0) { + return 0; + } + } + + /* There's no special character. Just make sure that the next + * characters of each string match. + */ + + if (*pattern != *string) { + return 0; + } + + thisCharOK: pattern += 1; + string += 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetResult -- + * + * Arrange for "string" to be the Tcl return value. + * + * Results: + * None. + * + * Side effects: + * interp->result is left pointing either to "string" (if "copy" is 0) + * or to a copy of string. Also, the object result is reset. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetResult(interp, string, freeProc) + Tcl_Interp *interp; /* Interpreter with which to associate the + * return value. */ + char *string; /* Value to be returned. If NULL, the + * result is set to an empty string. */ + Tcl_FreeProc *freeProc; /* Gives information about the string: + * TCL_STATIC, TCL_VOLATILE, or the address + * of a Tcl_FreeProc such as free. */ +{ + Interp *iPtr = (Interp *) interp; + int length; + Tcl_FreeProc *oldFreeProc = iPtr->freeProc; + char *oldResult = iPtr->result; + + if (string == NULL) { + iPtr->resultSpace[0] = 0; + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } else if (freeProc == TCL_VOLATILE) { + length = strlen(string); + if (length > TCL_RESULT_SIZE) { + iPtr->result = (char *) ckalloc((unsigned) length+1); + iPtr->freeProc = TCL_DYNAMIC; + } else { + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } + strcpy(iPtr->result, string); + } else { + iPtr->result = string; + iPtr->freeProc = freeProc; + } + + /* + * If the old result was dynamically-allocated, free it up. Do it + * here, rather than at the beginning, in case the new result value + * was part of the old result value. + */ + + if (oldFreeProc != 0) { + if ((oldFreeProc == TCL_DYNAMIC) + || (oldFreeProc == (Tcl_FreeProc *) free)) { + ckfree(oldResult); + } else { + (*oldFreeProc)(oldResult); + } + } + + /* + * Reset the object result since we just set the string result. + */ + + TclResetObjResult(iPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetStringResult -- + * + * Returns an interpreter's result value as a string. + * + * Results: + * The interpreter's result as a string. + * + * Side effects: + * If the string result is empty, the object result is moved to the + * string result, then the object result is reset. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetStringResult(interp) + Tcl_Interp *interp; /* Interpreter whose result to return. */ +{ + /* + * If the string result is empty, move the object result to the + * string result, then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + if (*(interp->result) == 0) { + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + } + return interp->result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetObjResult -- + * + * Arrange for objPtr to be an interpreter's result value. + * + * Results: + * None. + * + * Side effects: + * interp->objResultPtr is left pointing to the object referenced + * by objPtr. The object's reference count is incremented since + * there is now a new reference to it. The reference count for any + * old objResultPtr value is decremented. Also, the string result + * is reset. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetObjResult(interp, objPtr) + Tcl_Interp *interp; /* Interpreter with which to associate the + * return object value. */ + Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the + * obj result is made an empty string + * object. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *oldObjResult = iPtr->objResultPtr; + + iPtr->objResultPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ + + /* + * We wait until the end to release the old object result, in case + * we are setting the result to itself. + */ + + TclDecrRefCount(oldObjResult); + + /* + * Reset the string result since we just set the result object. + */ + + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + ckfree(iPtr->result); + } else { + (*iPtr->freeProc)(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetObjResult -- + * + * Returns an interpreter's result value as a Tcl object. The object's + * reference count is not modified; the caller must do that if it + * needs to hold on to a long-term reference to it. + * + * Results: + * The interpreter's result as an object. + * + * Side effects: + * If the interpreter has a non-empty string result, the result object + * is either empty or stale because some procedure set interp->result + * directly. If so, the string result is moved to the result object + * then the string result is reset. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_GetObjResult(interp) + Tcl_Interp *interp; /* Interpreter whose result to return. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *objResultPtr; + int length; + + /* + * If the string result is non-empty, move the string result to the + * object result, then reset the string result. + */ + + if (*(iPtr->result) != 0) { + TclResetObjResult(iPtr); + + objResultPtr = iPtr->objResultPtr; + length = strlen(iPtr->result); + TclInitStringRep(objResultPtr, iPtr->result, length); + + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + ckfree(iPtr->result); + } else { + (*iPtr->freeProc)(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + } + return iPtr->objResultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendResult -- + * + * Append a variable number of strings onto the interpreter's string + * result. + * + * Results: + * None. + * + * Side effects: + * The result of the interpreter given by the first argument is + * extended by the strings given by the second and following arguments + * (up to a terminating NULL argument). + * + * If the string result is empty, the object result is moved to the + * string result, then the object result is reset. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + va_list argList; + Interp *iPtr; + char *string; + int newSpace; + + /* + * If the string result is empty, move the object result to the + * string result, then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + if (*(iPtr->result) == 0) { + Tcl_SetResult((Tcl_Interp *) iPtr, + TclGetStringFromObj(Tcl_GetObjResult((Tcl_Interp *) iPtr), + (int *) NULL), + TCL_VOLATILE); + } + + /* + * Scan through all the arguments to see how much space is needed. + */ + + newSpace = 0; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + newSpace += strlen(string); + } + va_end(argList); + + /* + * If the append buffer isn't already setup and large enough to hold + * the new data, set it up. + */ + + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, newSpace); + } + + /* + * Now go through all the argument strings again, copying them into the + * buffer. + */ + + TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + strcpy(iPtr->appendResult + iPtr->appendUsed, string); + iPtr->appendUsed += strlen(string); + } + va_end(argList); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendElement -- + * + * Convert a string to a valid Tcl list element and append it to the + * result (which is ostensibly a list). + * + * Results: + * None. + * + * Side effects: + * The result in the interpreter given by the first argument is + * extended with a list element converted from string. A separator + * space is added before the converted list element unless the current + * result is empty, contains the single character "{", or ends in " {". + * + * If the string result is empty, the object result is moved to the + * string result, then the object result is reset. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendElement(interp, string) + Tcl_Interp *interp; /* Interpreter whose result is to be + * extended. */ + char *string; /* String to convert to list element and + * add to result. */ +{ + Interp *iPtr = (Interp *) interp; + char *dst; + int size; + int flags; + + /* + * If the string result is empty, move the object result to the + * string result, then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + if (*(iPtr->result) == 0) { + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + } + + /* + * See how much space is needed, and grow the append buffer if + * needed to accommodate the list element. + */ + + size = Tcl_ScanElement(string, &flags) + 1; + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, size+iPtr->appendUsed); + } + + /* + * Convert the string into a list element and copy it to the + * buffer that's forming, with a space separator if needed. + */ + + dst = iPtr->appendResult + iPtr->appendUsed; + if (TclNeedSpace(iPtr->appendResult, dst)) { + iPtr->appendUsed++; + *dst = ' '; + dst++; + } + iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); +} + +/* + *---------------------------------------------------------------------- + * + * SetupAppendBuffer -- + * + * This procedure makes sure that there is an append buffer properly + * initialized, if necessary, from the interpreter's result, and + * that it has at least enough room to accommodate newSpace new + * bytes of information. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +SetupAppendBuffer(iPtr, newSpace) + Interp *iPtr; /* Interpreter whose result is being set up. */ + int newSpace; /* Make sure that at least this many bytes + * of new information may be added. */ +{ + int totalSpace; + + /* + * Make the append buffer larger, if that's necessary, then copy the + * result into the append buffer and make the append buffer the official + * Tcl result. + */ + + if (iPtr->result != iPtr->appendResult) { + /* + * If an oversized buffer was used recently, then free it up + * so we go back to a smaller buffer. This avoids tying up + * memory forever after a large operation. + */ + + if (iPtr->appendAvl > 500) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + } + iPtr->appendUsed = strlen(iPtr->result); + } else if (iPtr->result[iPtr->appendUsed] != 0) { + /* + * Most likely someone has modified a result created by + * Tcl_AppendResult et al. so that it has a different size. + * Just recompute the size. + */ + + iPtr->appendUsed = strlen(iPtr->result); + } + + totalSpace = newSpace + iPtr->appendUsed; + if (totalSpace >= iPtr->appendAvl) { + char *new; + + if (totalSpace < 100) { + totalSpace = 200; + } else { + totalSpace *= 2; + } + new = (char *) ckalloc((unsigned) totalSpace); + strcpy(new, iPtr->result); + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + iPtr->appendResult = new; + iPtr->appendAvl = totalSpace; + } else if (iPtr->result != iPtr->appendResult) { + strcpy(iPtr->appendResult, iPtr->result); + } + + Tcl_FreeResult((Tcl_Interp *) iPtr); + iPtr->result = iPtr->appendResult; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FreeResult -- + * + * This procedure frees up the memory associated with an interpreter's + * string result. It also resets the interpreter's result object. + * Tcl_FreeResult is most commonly used when a procedure is about to + * replace one result value with another. + * + * Results: + * None. + * + * Side effects: + * Frees the memory associated with interp's string result and sets + * interp->freeProc to zero, but does not change interp->result or + * clear error state. Resets interp's result object to an unshared + * empty object. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FreeResult(interp) + Tcl_Interp *interp; /* Interpreter for which to free result. */ +{ + Interp *iPtr = (Interp *) interp; + + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + ckfree(iPtr->result); + } else { + (*iPtr->freeProc)(iPtr->result); + } + iPtr->freeProc = 0; + } + + TclResetObjResult(iPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ResetResult -- + * + * This procedure resets both the interpreter's string and object + * results. + * + * Results: + * None. + * + * Side effects: + * It resets the result object to an unshared empty object. It + * then restores the interpreter's string result area to its default + * initialized state, freeing up any memory that may have been + * allocated. It also clears any error information for the interpreter. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ResetResult(interp) + Tcl_Interp *interp; /* Interpreter for which to clear result. */ +{ + Interp *iPtr = (Interp *) interp; + + TclResetObjResult(iPtr); + + Tcl_FreeResult(interp); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + + iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrorCode -- + * + * This procedure is called to record machine-readable information + * about an error that is about to be returned. + * + * Results: + * None. + * + * Side effects: + * The errorCode global variable is modified to hold all of the + * arguments to this procedure, in a list form with each argument + * becoming one element of the list. A flag is set internally + * to remember that errorCode has been set, so the variable doesn't + * get set automatically when the error is returned. + * + *---------------------------------------------------------------------- + */ + /* VARARGS2 */ +void +Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + va_list argList; + char *string; + int flags; + Interp *iPtr; + + /* + * Scan through the arguments one at a time, appending them to + * $errorCode as list elements. + */ + + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", + (char *) NULL, string, flags); + flags |= TCL_APPEND_VALUE; + } + va_end(argList); + iPtr->flags |= ERROR_CODE_SET; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetObjErrorCode -- + * + * This procedure is called to record machine-readable information + * about an error that is about to be returned. The caller should + * build a list object up and pass it to this routine. + * + * Results: + * None. + * + * Side effects: + * The errorCode global variable is modified to be the new value. + * A flag is set internally to remember that errorCode has been + * set, so the variable doesn't get set automatically when the + * error is returned. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetObjErrorCode(interp, errorObjPtr) + Tcl_Interp *interp; + Tcl_Obj *errorObjPtr; +{ + Tcl_Obj *namePtr; + Interp *iPtr; + + namePtr = Tcl_NewStringObj("errorCode", -1); + iPtr = (Interp *) interp; + Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, errorObjPtr, + TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; + Tcl_DecrRefCount(namePtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpCompile -- + * + * Compile a regular expression into a form suitable for fast + * matching. This procedure retains a small cache of pre-compiled + * regular expressions in the interpreter, in order to avoid + * compilation costs as much as possible. + * + * Results: + * The return value is a pointer to the compiled form of string, + * suitable for passing to Tcl_RegExpExec. This compiled form + * is only valid up until the next call to this procedure, so + * don't keep these around for a long time! If an error occurred + * while compiling the pattern, then NULL is returned and an error + * message is left in interp->result. + * + * Side effects: + * The cache of compiled regexp's in interp will be modified to + * hold information for string, if such information isn't already + * present in the cache. + * + *---------------------------------------------------------------------- + */ + +Tcl_RegExp +Tcl_RegExpCompile(interp, string) + Tcl_Interp *interp; /* For use in error reporting. */ + char *string; /* String for which to produce + * compiled regular expression. */ +{ + Interp *iPtr = (Interp *) interp; + int i, length; + regexp *result; + + length = strlen(string); + for (i = 0; i < NUM_REGEXPS; i++) { + if ((length == iPtr->patLengths[i]) + && (strcmp(string, iPtr->patterns[i]) == 0)) { + /* + * Move the matched pattern to the first slot in the + * cache and shift the other patterns down one position. + */ + + if (i != 0) { + int j; + char *cachedString; + + cachedString = iPtr->patterns[i]; + result = iPtr->regexps[i]; + for (j = i-1; j >= 0; j--) { + iPtr->patterns[j+1] = iPtr->patterns[j]; + iPtr->patLengths[j+1] = iPtr->patLengths[j]; + iPtr->regexps[j+1] = iPtr->regexps[j]; + } + iPtr->patterns[0] = cachedString; + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + } + return (Tcl_RegExp) iPtr->regexps[0]; + } + } + + /* + * No match in the cache. Compile the string and add it to the + * cache. + */ + + TclRegError((char *) NULL); + result = TclRegComp(string); + if (TclGetRegError() != NULL) { + Tcl_AppendResult(interp, + "couldn't compile regular expression pattern: ", + TclGetRegError(), (char *) NULL); + return NULL; + } + if (iPtr->patterns[NUM_REGEXPS-1] != NULL) { + ckfree(iPtr->patterns[NUM_REGEXPS-1]); + ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]); + } + for (i = NUM_REGEXPS - 2; i >= 0; i--) { + iPtr->patterns[i+1] = iPtr->patterns[i]; + iPtr->patLengths[i+1] = iPtr->patLengths[i]; + iPtr->regexps[i+1] = iPtr->regexps[i]; + } + iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1)); + strcpy(iPtr->patterns[0], string); + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + return (Tcl_RegExp) result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpExec -- + * + * Execute the regular expression matcher using a compiled form + * of a regular expression and save information about any match + * that is found. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and interp->result contains an error message. + * Otherwise the return value is 1 if a matching range is + * found and 0 if there is no matching range. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpExec(interp, re, string, start) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tcl_RegExp re; /* Compiled regular expression; must have + * been returned by previous call to + * Tcl_RegExpCompile. */ + char *string; /* String against which to match re. */ + char *start; /* If string is part of a larger string, + * this identifies beginning of larger + * string, so that "^" won't match. */ +{ + int match; + + regexp *regexpPtr = (regexp *) re; + TclRegError((char *) NULL); + match = TclRegExec(regexpPtr, string, start); + if (TclGetRegError() != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error while matching regular expression: ", + TclGetRegError(), (char *) NULL); + return -1; + } + return match; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpRange -- + * + * Returns pointers describing the range of a regular expression match, + * or one of the subranges within the match. + * + * Results: + * The variables at *startPtr and *endPtr are modified to hold the + * addresses of the endpoints of the range given by index. If the + * specified range doesn't exist then NULLs are returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_RegExpRange(re, index, startPtr, endPtr) + Tcl_RegExp re; /* Compiled regular expression that has + * been passed to Tcl_RegExpExec. */ + int index; /* 0 means give the range of the entire + * match, > 0 means give the range of + * a matching subrange. Must be no greater + * than NSUBEXP. */ + char **startPtr; /* Store address of first character in + * (sub-) range here. */ + char **endPtr; /* Store address of character just after last + * in (sub-) range here. */ +{ + regexp *regexpPtr = (regexp *) re; + + if (index >= NSUBEXP) { + *startPtr = *endPtr = NULL; + } else { + *startPtr = regexpPtr->startp[index]; + *endPtr = regexpPtr->endp[index]; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpMatch -- + * + * See if a string matches a regular expression. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and interp->result contains an error message. + * Otherwise the return value is 1 if "string" matches "pattern" + * and 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpMatch(interp, string, pattern) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* String. */ + char *pattern; /* Regular expression to match against + * string. */ +{ + Tcl_RegExp re; + + re = Tcl_RegExpCompile(interp, pattern); + if (re == NULL) { + return -1; + } + return Tcl_RegExpExec(interp, re, string, string); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringInit -- + * + * Initializes a dynamic string, discarding any previous contents + * of the string (Tcl_DStringFree should have been called already + * if the dynamic string was previously in use). + * + * Results: + * None. + * + * Side effects: + * The dynamic string is initialized to be empty. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringInit(dsPtr) + Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */ +{ + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringAppend -- + * + * Append more characters to the current value of a dynamic string. + * + * Results: + * The return value is a pointer to the dynamic string's new value. + * + * Side effects: + * Length bytes from string (or all of string if length is less + * than zero) are added to the current value of the string. Memory + * gets reallocated if needed to accomodate the string's new size. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_DStringAppend(dsPtr, string, length) + Tcl_DString *dsPtr; /* Structure describing dynamic string. */ + CONST char *string; /* String to append. If length is -1 then + * this must be null-terminated. */ + int length; /* Number of characters from string to + * append. If < 0, then append all of string, + * up to null at end. */ +{ + int newSize; + char *newString, *dst; + CONST char *end; + + if (length < 0) { + length = strlen(string); + } + newSize = length + dsPtr->length; + + /* + * Allocate a larger buffer for the string if the current one isn't + * large enough. Allocate extra space in the new buffer so that there + * will be room to grow before we have to allocate again. + */ + + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize*2; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + + /* + * Copy the new string into the buffer at the end of the old + * one. + */ + + for (dst = dsPtr->string + dsPtr->length, end = string+length; + string < end; string++, dst++) { + *dst = *string; + } + *dst = '\0'; + dsPtr->length += length; + return dsPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringAppendElement -- + * + * Append a list element to the current value of a dynamic string. + * + * Results: + * The return value is a pointer to the dynamic string's new value. + * + * Side effects: + * String is reformatted as a list element and added to the current + * value of the string. Memory gets reallocated if needed to + * accomodate the string's new size. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_DStringAppendElement(dsPtr, string) + Tcl_DString *dsPtr; /* Structure describing dynamic string. */ + CONST char *string; /* String to append. Must be + * null-terminated. */ +{ + int newSize, flags; + char *dst, *newString; + + newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; + + /* + * Allocate a larger buffer for the string if the current one isn't + * large enough. Allocate extra space in the new buffer so that there + * will be room to grow before we have to allocate again. + * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string + * to a larger buffer, since there may be embedded NULLs in the + * string in some cases. + */ + + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize*2; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + + /* + * Convert the new string to a list element and copy it into the + * buffer at the end, with a space, if needed. + */ + + dst = dsPtr->string + dsPtr->length; + if (TclNeedSpace(dsPtr->string, dst)) { + *dst = ' '; + dst++; + dsPtr->length++; + } + dsPtr->length += Tcl_ConvertElement(string, dst, flags); + return dsPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringSetLength -- + * + * Change the length of a dynamic string. This can cause the + * string to either grow or shrink, depending on the value of + * length. + * + * Results: + * None. + * + * Side effects: + * The length of dsPtr is changed to length and a null byte is + * stored at that position in the string. If length is larger + * than the space allocated for dsPtr, then a panic occurs. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringSetLength(dsPtr, length) + Tcl_DString *dsPtr; /* Structure describing dynamic string. */ + int length; /* New length for dynamic string. */ +{ + if (length < 0) { + length = 0; + } + if (length >= dsPtr->spaceAvl) { + char *newString; + + dsPtr->spaceAvl = length+1; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + + /* + * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string + * to a larger buffer, since there may be embedded NULLs in the + * string in some cases. + */ + + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + dsPtr->length = length; + dsPtr->string[length] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringFree -- + * + * Frees up any memory allocated for the dynamic string and + * reinitializes the string to an empty state. + * + * Results: + * None. + * + * Side effects: + * The previous contents of the dynamic string are lost, and + * the new value is an empty string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringFree(dsPtr) + Tcl_DString *dsPtr; /* Structure describing dynamic string. */ +{ + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringResult -- + * + * This procedure moves the value of a dynamic string into an + * interpreter as its string result. Afterwards, the dynamic string + * is reset to an empty string. + * + * Results: + * None. + * + * Side effects: + * The string is "moved" to interp's result, and any existing + * string result for interp is freed. dsPtr is reinitialized to + * an empty string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringResult(interp, dsPtr) + Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become the + * result of interp. */ +{ + Tcl_ResetResult(interp); + + if (dsPtr->string != dsPtr->staticSpace) { + interp->result = dsPtr->string; + interp->freeProc = TCL_DYNAMIC; + } else if (dsPtr->length < TCL_RESULT_SIZE) { + interp->result = ((Interp *) interp)->resultSpace; + strcpy(interp->result, dsPtr->string); + } else { + Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); + } + + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringGetResult -- + * + * This procedure moves an interpreter's result into a dynamic string. + * + * Results: + * None. + * + * Side effects: + * The interpreter's string result is cleared, and the previous + * contents of dsPtr are freed. + * + * If the string result is empty, the object result is moved to the + * string result, then the object result is reset. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringGetResult(interp, dsPtr) + Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become the + * result of interp. */ +{ + Interp *iPtr = (Interp *) interp; + + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + + /* + * If the string result is empty, move the object result to the + * string result, then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + if (*(iPtr->result) == 0) { + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + } + + dsPtr->length = strlen(iPtr->result); + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + dsPtr->string = iPtr->result; + dsPtr->spaceAvl = dsPtr->length+1; + } else { + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); + strcpy(dsPtr->string, iPtr->result); + (*iPtr->freeProc)(iPtr->result); + } + dsPtr->spaceAvl = dsPtr->length+1; + iPtr->freeProc = NULL; + } else { + if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); + dsPtr->spaceAvl = dsPtr->length + 1; + } + strcpy(dsPtr->string, iPtr->result); + } + + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringStartSublist -- + * + * This procedure adds the necessary information to a dynamic + * string (e.g. " {" to start a sublist. Future element + * appends will be in the sublist rather than the main list. + * + * Results: + * None. + * + * Side effects: + * Characters get added to the dynamic string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringStartSublist(dsPtr) + Tcl_DString *dsPtr; /* Dynamic string. */ +{ + if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { + Tcl_DStringAppend(dsPtr, " {", -1); + } else { + Tcl_DStringAppend(dsPtr, "{", -1); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringEndSublist -- + * + * This procedure adds the necessary characters to a dynamic + * string to end a sublist (e.g. "}"). Future element appends + * will be in the enclosing (sub)list rather than the current + * sublist. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringEndSublist(dsPtr) + Tcl_DString *dsPtr; /* Dynamic string. */ +{ + Tcl_DStringAppend(dsPtr, "}", -1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PrintDouble -- + * + * Given a floating-point value, this procedure converts it to + * an ASCII string using. + * + * Results: + * The ASCII equivalent of "value" is written at "dst". It is + * written using the current precision, and it is guaranteed to + * contain a decimal point or exponent, so that it looks like + * a floating-point value and not an integer. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_PrintDouble(interp, value, dst) + Tcl_Interp *interp; /* Interpreter whose tcl_precision + * variable used to be used to control + * printing. It's ignored now. */ + double value; /* Value to print as string. */ + char *dst; /* Where to store converted value; + * must have at least TCL_DOUBLE_SPACE + * characters. */ +{ + char *p; + + sprintf(dst, precisionFormat, value); + + /* + * If the ASCII result looks like an integer, add ".0" so that it + * doesn't look like an integer anymore. This prevents floating-point + * values from being converted to integers unintentionally. + */ + + for (p = dst; *p != 0; p++) { + if ((*p == '.') || (isalpha(UCHAR(*p)))) { + return; + } + } + p[0] = '.'; + p[1] = '0'; + p[2] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrecTraceProc -- + * + * This procedure is invoked whenever the variable "tcl_precision" + * is written. + * + * Results: + * Returns NULL if all went well, or an error message if the + * new value for the variable doesn't make sense. + * + * Side effects: + * If the new value doesn't make sense then this procedure + * undoes the effect of the variable modification. Otherwise + * it modifies the format string that's used by Tcl_PrintDouble. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +char * +TclPrecTraceProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + char *value, *end; + int prec; + + /* + * If the variable is unset, then recreate the trace. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar2(interp, name1, name2, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES + |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); + } + return (char *) NULL; + } + + /* + * When the variable is read, reset its value from our shared + * value. This is needed in case the variable was modified in + * some other interpreter so that this interpreter's value is + * out of date. + */ + + if (flags & TCL_TRACE_READS) { + Tcl_SetVar2(interp, name1, name2, precisionString, + flags & TCL_GLOBAL_ONLY); + return (char *) NULL; + } + + /* + * The variable is being written. Check the new value and disallow + * it if it isn't reasonable or if this is a safe interpreter (we + * don't want safe interpreters messing up the precision of other + * interpreters). + */ + + if (Tcl_IsSafe(interp)) { + Tcl_SetVar2(interp, name1, name2, precisionString, + flags & TCL_GLOBAL_ONLY); + return "can't modify precision from a safe interpreter"; + } + value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + prec = strtoul(value, &end, 10); + if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || + (end == value) || (*end != 0)) { + Tcl_SetVar2(interp, name1, name2, precisionString, + flags & TCL_GLOBAL_ONLY); + return "improper value for precision"; + } + TclFormatInt(precisionString, prec); + sprintf(precisionFormat, "%%.%dg", prec); + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclNeedSpace -- + * + * This procedure checks to see whether it is appropriate to + * add a space before appending a new list element to an + * existing string. + * + * Results: + * The return value is 1 if a space is appropriate, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclNeedSpace(start, end) + char *start; /* First character in string. */ + char *end; /* End of string (place where space will + * be added, if appropriate). */ +{ + /* + * A space is needed unless either + * (a) we're at the start of the string, or + * (b) the trailing characters of the string consist of one or more + * open curly braces preceded by a space or extending back to + * the beginning of the string. + * (c) the trailing characters of the string consist of a space + * preceded by a character other than backslash. + */ + + if (end == start) { + return 0; + } + end--; + if (*end != '{') { + if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) { + return 0; + } + return 1; + } + do { + if (end == start) { + return 0; + } + end--; + } while (*end == '{'); + if (isspace(UCHAR(*end))) { + return 0; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclFormatInt -- + * + * This procedure formats an integer into a sequence of decimal digit + * characters in a buffer. If the integer is negative, a minus sign is + * inserted at the start of the buffer. A null character is inserted at + * the end of the formatted characters. It is the caller's + * responsibility to ensure that enough storage is available. This + * procedure has the effect of sprintf(buffer, "%d", n) but is faster. + * + * Results: + * An integer representing the number of characters formatted, not + * including the terminating \0. + * + * Side effects: + * The formatted characters are written into the storage pointer to + * by the "buffer" argument. + * + *---------------------------------------------------------------------- + */ + +int +TclFormatInt(buffer, n) + char *buffer; /* Points to the storage into which the + * formatted characters are written. */ + long n; /* The integer to format. */ +{ + long intVal; + int i; + int numFormatted, j; + char *digits = "0123456789"; + + /* + * Check first whether "n" is the maximum negative value. This is + * -2^(m-1) for an m-bit word, and has no positive equivalent; + * negating it produces the same value. + */ + + if (n == -n) { + sprintf(buffer, "%ld", n); + return strlen(buffer); + } + + /* + * Generate the characters of the result backwards in the buffer. + */ + + intVal = (n < 0? -n : n); + i = 0; + buffer[0] = '\0'; + do { + i++; + buffer[i] = digits[intVal % 10]; + intVal = intVal/10; + } while (intVal > 0); + if (n < 0) { + i++; + buffer[i] = '-'; + } + numFormatted = i; + + /* + * Now reverse the characters. + */ + + for (j = 0; j < i; j++, i--) { + char tmp = buffer[i]; + buffer[i] = buffer[j]; + buffer[j] = tmp; + } + return numFormatted; +} + +/* + *---------------------------------------------------------------------- + * + * TclLooksLikeInt -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +int +TclLooksLikeInt(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; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetIntForIndex -- + * + * This procedure returns an integer corresponding to the list index + * held in a Tcl object. The Tcl object's value is expected to be + * either an integer or the string "end". + * + * Results: + * The return value is normally TCL_OK, which means that the index was + * successfully stored into the location referenced by "indexPtr". If + * the Tcl object referenced by "objPtr" has the value "end", the + * value stored is "endValue". If "objPtr"s values is not "end" and + * can not be converted to an integer, TCL_ERROR is returned and, if + * "interp" is non-NULL, an error message is left in the interpreter's + * result object. + * + * Side effects: + * The object referenced by "objPtr" might be converted to an + * integer object. + * + *---------------------------------------------------------------------- + */ + +int +TclGetIntForIndex(interp, objPtr, endValue, indexPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left + * after errors. */ + Tcl_Obj *objPtr; /* Points to an object containing either + * "end" or an integer. */ + int endValue; /* The value to be stored at "indexPtr" if + * "objPtr" holds "end". */ + int *indexPtr; /* Location filled in with an integer + * representing an index. */ +{ + Interp *iPtr = (Interp *) interp; + char *bytes; + int index, length, result; + + /* + * THIS FAILS IF THE INDEX OBJECT'S STRING REP CONTAINS NULLS. + */ + + if (objPtr->typePtr == &tclIntType) { + *indexPtr = (int)objPtr->internalRep.longValue; + return TCL_OK; + } + + bytes = TclGetStringFromObj(objPtr, &length); + if ((*bytes == 'e') + && (strncmp(bytes, "end", (unsigned) length) == 0)) { + index = endValue; + } else { + result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objPtr, &index); + if (result != TCL_OK) { + if (iPtr != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad index \"", bytes, + "\": must be integer or \"end\"", (char *) NULL); + } + return result; + } + } + *indexPtr = index; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetNameOfExecutable -- + * + * This procedure simply returns a pointer to the internal full + * path name of the executable file as computed by + * Tcl_FindExecutable. This procedure call is the C API + * equivalent to the "info nameofexecutable" command. + * + * Results: + * A pointer to the internal string or NULL if the internal full + * path name has not been computed or unknown. + * + * Side effects: + * The object referenced by "objPtr" might be converted to an + * integer object. + * + *---------------------------------------------------------------------- + */ + +CONST char * +Tcl_GetNameOfExecutable() +{ + return (tclExecutableName); +} diff --git a/tcl/generic/tclVar.c b/tcl/generic/tclVar.c new file mode 100644 index 00000000000..e191087e674 --- /dev/null +++ b/tcl/generic/tclVar.c @@ -0,0 +1,4620 @@ +/* + * tclVar.c -- + * + * This file contains routines that implement Tcl variables + * (both scalars and arrays). + * + * The implementation of arrays is modelled after an initial + * implementation by Mark Diekhans and Karl Lehenbauer. + * + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994-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. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The strings below are used to indicate what went wrong when a + * variable access is denied. + */ + +static char *noSuchVar = "no such variable"; +static char *isArray = "variable is array"; +static char *needArray = "variable isn't array"; +static char *noSuchElement = "no such element in array"; +static char *danglingUpvar = "upvar refers to element in deleted array"; +static char *badNamespace = "parent namespace doesn't exist"; +static char *missingName = "missing variable name"; + +/* + * Forward references to procedures defined later in this file: + */ + +static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, + Var *varPtr, char *part1, char *part2, + int flags)); +static void CleanupVar _ANSI_ARGS_((Var *varPtr, + Var *arrayPtr)); +static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr)); +static void DeleteArray _ANSI_ARGS_((Interp *iPtr, + char *arrayName, Var *varPtr, int flags)); +static int MakeUpvar _ANSI_ARGS_(( + Interp *iPtr, CallFrame *framePtr, + char *otherP1, char *otherP2, int otherFlags, + char *myName, int myFlags)); +static Var * NewVar _ANSI_ARGS_((void)); +static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, + Var *varPtr, char *varName, char *string)); +static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, char *operation, + char *reason)); + +/* + *---------------------------------------------------------------------- + * + * TclLookupVar -- + * + * This procedure is used by virtually all of the variable code to + * locate a variable given its name(s). + * + * Results: + * The return value is a pointer to the variable structure indicated by + * part1 and part2, or NULL if the variable couldn't be found. If the + * variable is found, *arrayPtrPtr is filled in with the address of the + * variable structure for the array that contains the variable (or NULL + * if the variable is a scalar). If the variable can't be found and + * either createPart1 or createPart2 are 1, a new as-yet-undefined + * (VAR_UNDEFINED) variable structure is created, entered into a hash + * table, and returned. + * + * If the variable isn't found and creation wasn't specified, or some + * other error occurs, NULL is returned and an error message is left in + * interp->result if TCL_LEAVE_ERR_MSG is set in flags. (The result + * isn't put in interp->objResultPtr because this procedure is used + * by so many string-based routines.) + * + * Note: it's possible for the variable returned to be VAR_UNDEFINED + * even if createPart1 or createPart2 are 1 (these only cause the hash + * table entry or array to be created). For example, the variable might + * be a global that has been unset but is still referenced by a + * procedure, or a variable that has been unset but it only being kept + * in existence (if VAR_UNDEFINED) by a trace. + * + * Side effects: + * New hashtable entries may be created if createPart1 or createPart2 + * are 1. + * + *---------------------------------------------------------------------- + */ + +Var * +TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, + arrayPtrPtr) + Tcl_Interp *interp; /* Interpreter to use for lookup. */ + char *part1; /* If part2 isn't NULL, this is the name of + * an array. Otherwise, if the + * TCL_PARSE_PART1 flag bit is set this + * is a full variable name that could + * include a parenthesized array elemnt. If + * TCL_PARSE_PART1 isn't present, then + * this is the name of a scalar variable. */ + char *part2; /* Name of element within array, or NULL. */ + int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_LEAVE_ERR_MSG, and + * TCL_PARSE_PART1 bits matter. */ + char *msg; /* Verb to use in error messages, e.g. + * "read" or "set". Only needed if + * TCL_LEAVE_ERR_MSG is set in flags. */ + int createPart1; /* If 1, create hash table entry for part 1 + * of name, if it doesn't already exist. If + * 0, return error if it doesn't exist. */ + int createPart2; /* If 1, create hash table entry for part 2 + * of name, if it doesn't already exist. If + * 0, return error if it doesn't exist. */ + Var **arrayPtrPtr; /* If the name refers to an element of an + * array, *arrayPtrPtr gets filled in with + * address of array variable. Otherwise + * this is set to NULL. */ +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + /* Points to the procedure call frame whose + * variables are currently in use. Same as + * the current procedure's frame, if any, + * unless an "uplevel" is executing. */ + Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which + * to look up the variable. */ + Tcl_Var var; /* Used to search for global names. */ + Var *varPtr; /* Points to the Var structure returned for + * the variable. */ + char *elName; /* Name of array element or NULL; may be + * same as part2, or may be openParen+1. */ + char *openParen, *closeParen; + /* If this procedure parses a name into + * array and index, these point to the + * parens around the index. Otherwise they + * are NULL. These are needed to restore + * the parens after parsing the name. */ + Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; + ResolverScheme *resPtr; + Tcl_HashEntry *hPtr; + register char *p; + int new, i, result; + + varPtr = NULL; + *arrayPtrPtr = NULL; + openParen = closeParen = NULL; + varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ + + /* + * If the name hasn't been parsed into array name and index yet, + * do it now. + */ + + elName = part2; + if (flags & TCL_PARSE_PART1) { + for (p = part1; ; p++) { + if (*p == 0) { + elName = NULL; + break; + } + if (*p == '(') { + openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p == ')') { + closeParen = p; + *openParen = 0; + elName = openParen+1; + } else { + openParen = NULL; + elName = NULL; + } + break; + } + } + } + + /* + * If this namespace has a variable resolver, then give it first + * crack at the variable resolution. It may return a Tcl_Var + * value, it may signal to continue onward, or it may signal + * an error. + */ + if ((flags & TCL_GLOBAL_ONLY) != 0 || iPtr->varFramePtr == NULL) { + cxtNsPtr = iPtr->globalNsPtr; + } + else { + cxtNsPtr = iPtr->varFramePtr->nsPtr; + } + + if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + resPtr = iPtr->resolverPtr; + + if (cxtNsPtr->varResProc) { + result = (*cxtNsPtr->varResProc)(interp, part1, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } else { + result = TCL_CONTINUE; + } + + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->varResProc) { + result = (*resPtr->varResProc)(interp, part1, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } + resPtr = resPtr->nextPtr; + } + + if (result == TCL_OK) { + varPtr = (Var *) var; + goto lookupVarPart2; + } + else if (result != TCL_CONTINUE) { + return (Var *) NULL; + } + } + + /* + * Look up part1. Look it up as either a namespace variable or as a + * local variable in a procedure call frame (varFramePtr). + * Interpret part1 as a namespace variable if: + * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag, + * 2) there is no active frame (we're at the global :: scope), + * 3) the active frame was pushed to define the namespace context + * for a "namespace eval" or "namespace inscope" command, + * 4) the name has namespace qualifiers ("::"s). + * Otherwise, if part1 is a local variable, search first in the + * frame's array of compiler-allocated local variables, then in its + * hashtable for runtime-created local variables. + * + * If createPart1 and the variable isn't found, create the variable and, + * if necessary, create varFramePtr's local var hashtable. + */ + + if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0) + || (varFramePtr == NULL) + || !varFramePtr->isProcCallFrame + || (strstr(part1, "::") != NULL)) { + char *tail; + + var = Tcl_FindNamespaceVar(interp, part1, (Tcl_Namespace *) NULL, + flags); + if (var != (Tcl_Var) NULL) { + varPtr = (Var *) var; + } + if (varPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_ResetResult(interp); + } + if (createPart1) { /* var wasn't found so create it */ + result = TclGetNamespaceForQualName(interp, part1, + (Namespace *) NULL, flags, &varNsPtr, &dummy1Ptr, + &dummy2Ptr, &tail); + if (result != TCL_OK) { + if (flags & TCL_LEAVE_ERR_MSG) { + /* + * Move the interpreter's object result to the + * string result, then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REP HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), + (int *) NULL), + TCL_VOLATILE); + } + goto done; + } + if (varNsPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, badNamespace); + } + goto done; + } + if (tail == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, missingName); + } + goto done; + } + hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new); + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = varNsPtr; + } else { /* var wasn't found and not to create it */ + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchVar); + } + goto done; + } + } + } else { /* local var: look in frame varFramePtr */ + Proc *procPtr = varFramePtr->procPtr; + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + Var *localVarPtr = varFramePtr->compiledLocals; + int part1Len = strlen(part1); + + for (i = 0; i < localCt; i++) { + if (!TclIsVarTemporary(localPtr)) { + char *localName = localVarPtr->name; + if ((part1[0] == localName[0]) + && (part1Len == localPtr->nameLength) + && (strcmp(part1, localName) == 0)) { + varPtr = localVarPtr; + break; + } + } + localVarPtr++; + localPtr = localPtr->nextPtr; + } + if (varPtr == NULL) { /* look in the frame's var hash table */ + tablePtr = varFramePtr->varTablePtr; + if (createPart1) { + if (tablePtr == NULL) { + tablePtr = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); + varFramePtr->varTablePtr = tablePtr; + } + hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new); + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = NULL; /* a local variable */ + } else { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + } + } else { + hPtr = NULL; + if (tablePtr != NULL) { + hPtr = Tcl_FindHashEntry(tablePtr, part1); + } + if (hPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchVar); + } + goto done; + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); + } + } + } + +lookupVarPart2: + if (openParen != NULL) { + *openParen = '('; + openParen = NULL; + } + + /* + * If varPtr is a link variable, we have a reference to some variable + * that was created through an "upvar" or "global" command. Traverse + * through any links until we find the referenced variable. + */ + + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + + /* + * If we're not dealing with an array element, return varPtr. + */ + + if (elName == NULL) { + goto done; + } + + /* + * We're dealing with an array element. Make sure the variable is an + * array and look up the element (create the element if desired). + */ + + if (TclIsVarUndefined(varPtr) && !TclIsVarArrayElement(varPtr)) { + if (!createPart1) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchVar); + } + varPtr = NULL; + goto done; + } + TclSetVarArray(varPtr); + TclClearVarUndefined(varPtr); + varPtr->value.tablePtr = + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); + } else if (!TclIsVarArray(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, needArray); + } + varPtr = NULL; + goto done; + } + *arrayPtrPtr = varPtr; + if (closeParen != NULL) { + *closeParen = 0; + } + if (createPart2) { + hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new); + if (closeParen != NULL) { + *closeParen = ')'; + } + if (new) { + if (varPtr->searchPtr != NULL) { + DeleteSearches(varPtr); + } + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = varNsPtr; + TclSetVarArrayElement(varPtr); + } + } else { + hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName); + if (closeParen != NULL) { + *closeParen = ')'; + } + if (hPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchElement); + } + varPtr = NULL; + goto done; + } + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); + + done: + if (openParen != NULL) { + *openParen = '('; + } + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVar -- + * + * Return the value of a Tcl variable as a string. + * + * Results: + * The return value points to the current value of varName as a string. + * If the variable is not defined or can't be read because of a clash + * in array usage then a NULL pointer is returned and an error message + * is left in interp->result if the TCL_LEAVE_ERR_MSG flag is set. + * Note: the return value is only valid up until the next change to the + * variable; if you depend on the value lasting longer than that, then + * make yourself a private copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetVar(interp, varName, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *varName; /* Name of a variable in interp. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG + * bits. */ +{ + return Tcl_GetVar2(interp, varName, (char *) NULL, + (flags | TCL_PARSE_PART1)); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVar2 -- + * + * Return the value of a Tcl variable as a string, given a two-part + * name consisting of array name and element within array. + * + * Results: + * The return value points to the current value of the variable given + * by part1 and part2 as a string. If the specified variable doesn't + * exist, or if there is a clash in array usage, then NULL is returned + * and a message will be left in interp->result if the + * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is only valid + * up until the next change to the variable; if you depend on the value + * lasting longer than that, then make yourself a private copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetVar2(interp, part1, part2, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + char *part1; /* Name of an array (if part2 is non-NULL) + * or the name of a variable. */ + char *part2; /* If non-NULL, gives the name of an element + * in the array part1. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_LEAVE_ERR_MSG, + * and TCL_PARSE_PART1 bits. */ +{ + register Tcl_Obj *part1Ptr; + register Tcl_Obj *part2Ptr = NULL; + Tcl_Obj *objPtr; + int length; + + length = strlen(part1); + TclNewObj(part1Ptr); + TclInitStringRep(part1Ptr, part1, length); + Tcl_IncrRefCount(part1Ptr); + + if (part2 != NULL) { + length = strlen(part2); + TclNewObj(part2Ptr); + TclInitStringRep(part2Ptr, part2, length); + Tcl_IncrRefCount(part2Ptr); + } + + objPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); + + TclDecrRefCount(part1Ptr); /* done with the part1 name object */ + if (part2Ptr != NULL) { + TclDecrRefCount(part2Ptr); /* and the part2 name object */ + } + + if (objPtr == NULL) { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + return NULL; + } + + /* + * THIS FAILS IF Tcl_ObjGetVar2's RESULT'S STRING REP HAS A NULL BYTE. + */ + + return TclGetStringFromObj(objPtr, (int *) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ObjGetVar2 -- + * + * Return the value of a Tcl variable as a Tcl object, given a + * two-part name consisting of array name and element within array. + * + * Results: + * The return value points to the current object value of the variable + * given by part1Ptr and part2Ptr. If the specified variable doesn't + * exist, or if there is a clash in array usage, then NULL is returned + * and a message will be left in the interpreter's result if the + * TCL_LEAVE_ERR_MSG flag is set. + * + * Side effects: + * The ref count for the returned object is _not_ incremented to + * reflect the returned reference; if you want to keep a reference to + * the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_LEAVE_ERR_MSG, and + * TCL_PARSE_PART1 bits. */ +{ + Interp *iPtr = (Interp *) interp; + register Var *varPtr; + Var *arrayPtr; + char *part1, *msg; + char *part2 = NULL; + + /* + * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. + */ + + part1 = TclGetStringFromObj(part1Ptr, (int *) NULL); + if (part2Ptr != NULL) { + part2 = TclGetStringFromObj(part2Ptr, (int *) NULL); + } + varPtr = TclLookupVar(interp, part1, part2, flags, "read", + /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * Invoke any traces that have been set for the variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_READS); + if (msg != NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "read", msg); + } + goto errorReturn; + } + } + + /* + * Return the element if it's an existing scalar variable. + */ + + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { + return varPtr->value.objPtr; + } + + if (flags & TCL_LEAVE_ERR_MSG) { + if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL) + && !TclIsVarUndefined(arrayPtr)) { + msg = noSuchElement; + } else if (TclIsVarArray(varPtr)) { + msg = isArray; + } else { + msg = noSuchVar; + } + VarErrMsg(interp, part1, part2, "read", msg); + } + + /* + * An error. If the variable doesn't exist anymore and no-one's using + * it, then free up the relevant structures and hash table entries. + */ + + errorReturn: + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, arrayPtr); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetIndexedScalar -- + * + * Return the Tcl object value of a local scalar variable in the active + * procedure, given its index in the procedure's array of compiler + * allocated local variables. + * + * Results: + * The return value points to the current object value of the variable + * given by localIndex. If the specified variable doesn't exist, or + * there is a clash in array usage, or an error occurs while executing + * variable traces, then NULL is returned and a message will be left in + * the interpreter's result if leaveErrorMsg is 1. + * + * Side effects: + * The ref count for the returned object is _not_ incremented to + * reflect the returned reference; if you want to keep a reference to + * the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + int localIndex; /* Index of variable in procedure's array + * of local variables. */ + int leaveErrorMsg; /* 1 if to leave an error message in + * interpreter's result on an error. + * Otherwise no error message is left. */ +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + /* Points to the procedure call frame whose + * variables are currently in use. Same as + * the current procedure's frame, if any, + * unless an "uplevel" is executing. */ + Var *compiledLocals = varFramePtr->compiledLocals; + Var *varPtr; /* Points to the variable's in-frame Var + * structure. */ + char *varName; /* Name of the local variable. */ + char *msg; + +#ifdef TCL_COMPILE_DEBUG + Proc *procPtr = varFramePtr->procPtr; + int localCt = procPtr->numCompiledLocals; + + if (compiledLocals == NULL) { + fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n", + localIndex, (unsigned int) varFramePtr); + panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", + (unsigned int) varFramePtr); + } + if ((localIndex < 0) || (localIndex >= localCt)) { + fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x with %i locals\n", + localIndex, (unsigned int) varFramePtr, localCt); + panic("TclGetIndexedScalar: bad local index %i in frame 0x%x", + localIndex, (unsigned int) varFramePtr); + } +#endif /* TCL_COMPILE_DEBUG */ + + varPtr = &(compiledLocals[localIndex]); + varName = varPtr->name; + + /* + * If varPtr is a link variable, we have a reference to some variable + * that was created through an "upvar" or "global" command, or we have a + * reference to a variable in an enclosing namespace. Traverse through + * any links until we find the referenced variable. + */ + + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + + /* + * Invoke any traces that have been set for the variable. + */ + + if (varPtr->tracePtr != NULL) { + msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, + TCL_TRACE_READS); + if (msg != NULL) { + if (leaveErrorMsg) { + VarErrMsg(interp, varName, NULL, "read", msg); + } + return NULL; + } + } + + /* + * Make sure we're dealing with a scalar variable and not an array, and + * that the variable exists (isn't undefined). + */ + + if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) { + if (leaveErrorMsg) { + if (TclIsVarArray(varPtr)) { + msg = isArray; + } else { + msg = noSuchVar; + } + VarErrMsg(interp, varName, NULL, "read", msg); + } + return NULL; + } + return varPtr->value.objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetElementOfIndexedArray -- + * + * Return the Tcl object value for an element in a local array + * variable. The element is named by the object elemPtr while the + * array is specified by its index in the active procedure's array + * of compiler allocated local variables. + * + * Results: + * The return value points to the current object value of the + * element. If the specified array or element doesn't exist, or there + * is a clash in array usage, or an error occurs while executing + * variable traces, then NULL is returned and a message will be left in + * the interpreter's result if leaveErrorMsg is 1. + * + * Side effects: + * The ref count for the returned object is _not_ incremented to + * reflect the returned reference; if you want to keep a reference to + * the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + int localIndex; /* Index of array variable in procedure's + * array of local variables. */ + Tcl_Obj *elemPtr; /* Points to an object holding the name of + * an element to get in the array. */ + int leaveErrorMsg; /* 1 if to leave an error message in + * the interpreter's result on an error. + * Otherwise no error message is left. */ +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + /* Points to the procedure call frame whose + * variables are currently in use. Same as + * the current procedure's frame, if any, + * unless an "uplevel" is executing. */ + Var *compiledLocals = varFramePtr->compiledLocals; + Var *arrayPtr; /* Points to the array's in-frame Var + * structure. */ + char *arrayName; /* Name of the local array. */ + Tcl_HashEntry *hPtr; + Var *varPtr = NULL; /* Points to the element's Var structure + * that we return. Initialized to avoid + * compiler warning. */ + char *elem, *msg; + int new; + +#ifdef TCL_COMPILE_DEBUG + Proc *procPtr = varFramePtr->procPtr; + int localCt = procPtr->numCompiledLocals; + + if (compiledLocals == NULL) { + fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element of local %i in frame 0x%x, no compiled locals\n", + localIndex, (unsigned int) varFramePtr); + panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", + (unsigned int) varFramePtr); + } + if ((localIndex < 0) || (localIndex >= localCt)) { + fprintf(stderr, "\nTclGetIndexedScalar: can't get element of local %i in frame 0x%x with %i locals\n", + localIndex, (unsigned int) varFramePtr, localCt); + panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x", + localIndex, (unsigned int) varFramePtr); + } +#endif /* TCL_COMPILE_DEBUG */ + + /* + * THIS FAILS IF THE ELEMENT NAME OBJECT'S STRING REP HAS A NULL BYTE. + */ + + elem = Tcl_GetStringFromObj(elemPtr, (int *) NULL); + arrayPtr = &(compiledLocals[localIndex]); + arrayName = arrayPtr->name; + + /* + * If arrayPtr is a link variable, we have a reference to some variable + * that was created through an "upvar" or "global" command, or we have a + * reference to a variable in an enclosing namespace. Traverse through + * any links until we find the referenced variable. + */ + + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + + /* + * Make sure we're dealing with an array and that the array variable + * exists (isn't undefined). + */ + + if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) { + if (leaveErrorMsg) { + VarErrMsg(interp, arrayName, elem, "read", noSuchVar); + } + goto errorReturn; + } + + /* + * Look up the element. Note that we must create the element (but leave + * it marked undefined) if it does not already exist. This allows a + * trace to create new array elements "on the fly" that did not exist + * before. A trace is always passed a variable for the array element. If + * the trace does not define the variable, it will be deleted below (at + * errorReturn) and an error returned. + */ + + hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new); + if (new) { + if (arrayPtr->searchPtr != NULL) { + DeleteSearches(arrayPtr); + } + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = varFramePtr->nsPtr; + TclSetVarArrayElement(varPtr); + } else { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + } + + /* + * Invoke any traces that have been set for the element variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, + TCL_TRACE_READS); + if (msg != NULL) { + if (leaveErrorMsg) { + VarErrMsg(interp, arrayName, elem, "read", msg); + } + goto errorReturn; + } + } + + /* + * Return the element if it's an existing scalar variable. + */ + + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { + return varPtr->value.objPtr; + } + + if (leaveErrorMsg) { + if (TclIsVarArray(varPtr)) { + msg = isArray; + } else { + msg = noSuchVar; + } + VarErrMsg(interp, arrayName, elem, "read", msg); + } + + /* + * An error. If the variable doesn't exist anymore and no-one's using + * it, then free up the relevant structures and hash table entries. + */ + + errorReturn: + if ((varPtr != NULL) && TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, NULL); /* the array is not in a hashtable */ + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCmd -- + * + * This procedure is invoked to process the "set" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * A variable's value may be changed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SetCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc == 2) { + char *value; + + value = Tcl_GetVar2(interp, argv[1], (char *) NULL, + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + if (value == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, value, TCL_VOLATILE); + return TCL_OK; + } else if (argc == 3) { + char *result; + + result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + if (result == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, result, TCL_VOLATILE); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?newValue?\"", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetVar -- + * + * Change the value of a variable. + * + * Results: + * Returns a pointer to the malloc'ed string which is the character + * representation of the variable's new value. The caller must not + * modify this string. If the write operation was disallowed then NULL + * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an + * explanatory message will be left in interp->result. Note that the + * returned string may not be the same as newValue; this is because + * variable traces may modify the variable's value. + * + * Side effects: + * If varName is defined as a local or global variable in interp, + * its value is changed to newValue. If varName isn't currently + * defined, then a new global variable by that name is created. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SetVar(interp, varName, newValue, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *varName; /* Name of a variable in interp. */ + char *newValue; /* New value for varName. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ +{ + return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, + (flags | TCL_PARSE_PART1)); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetVar2 -- + * + * Given a two-part variable name, which may refer either to a + * scalar variable or an element of an array, change the value + * of the variable. If the named scalar or array or element + * doesn't exist then create one. + * + * Results: + * Returns a pointer to the malloc'ed string which is the character + * representation of the variable's new value. The caller must not + * modify this string. If the write operation was disallowed because an + * array was expected but not found (or vice versa), then NULL is + * returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory + * message will be left in interp->result. Note that the returned + * string may not be the same as newValue; this is because variable + * traces may modify the variable's value. + * + * Side effects: + * The value of the given variable is set. If either the array + * or the entry didn't exist then a new one is created. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SetVar2(interp, part1, part2, newValue, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + char *part1; /* If part2 is NULL, this is name of scalar + * variable. Otherwise it is the name of + * an array. */ + char *part2; /* Name of an element within an array, or + * NULL. */ + char *newValue; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or + * TCL_PARSE_PART1. */ +{ + register Tcl_Obj *valuePtr; + register Tcl_Obj *part1Ptr; + register Tcl_Obj *part2Ptr = NULL; + Tcl_Obj *varValuePtr; + int length; + + /* + * Create an object holding the variable's new value and use + * Tcl_ObjSetVar2 to actually set the variable. + */ + + length = newValue ? strlen(newValue) : 0; + TclNewObj(valuePtr); + TclInitStringRep(valuePtr, newValue, length); + Tcl_IncrRefCount(valuePtr); + + length = strlen(part1) ; + TclNewObj(part1Ptr); + TclInitStringRep(part1Ptr, part1, length); + Tcl_IncrRefCount(part1Ptr); + + if (part2 != NULL) { + length = strlen(part2); + TclNewObj(part2Ptr); + TclInitStringRep(part2Ptr, part2, length); + Tcl_IncrRefCount(part2Ptr); + } + + varValuePtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, valuePtr, + flags); + + TclDecrRefCount(part1Ptr); /* done with the part1 name object */ + if (part2Ptr != NULL) { + TclDecrRefCount(part2Ptr); /* and the part2 name object */ + } + Tcl_DecrRefCount(valuePtr); /* done with the object */ + + if (varValuePtr == NULL) { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + return NULL; + } + + /* + * THIS FAILS IF Tcl_ObjSetVar2's RESULT'S STRING REP HAS A NULL BYTE. + */ + + return TclGetStringFromObj(varValuePtr, (int *) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ObjSetVar2 -- + * + * Given a two-part variable name, which may refer either to a scalar + * variable or an element of an array, change the value of the variable + * to a new Tcl object value. If the named scalar or array or element + * doesn't exist then create one. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the write operation was disallowed because an array was + * expected but not found (or vice versa), then NULL is returned; if + * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will + * be left in the interpreter's result. Note that the returned object + * may not be the same one referenced by newValuePtr; this is because + * variable traces may modify the variable's value. + * + * Side effects: + * The value of the given variable is set. If either the array or the + * entry didn't exist then a new variable is created. + * + * The reference count is decremented for any old value of the variable + * and incremented for its new value. If the new value for the variable + * is not the same one referenced by newValuePtr (perhaps as a result + * of a variable trace), then newValuePtr's ref count is left unchanged + * by Tcl_ObjSetVar2. newValuePtr's ref count is also left unchanged if + * we are appending it as a string value: that is, if "flags" includes + * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT. + * + * The reference count for the returned object is _not_ incremented: if + * you want to keep a reference to the object you must increment its + * ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + Tcl_Obj *newValuePtr; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or + * TCL_PARSE_PART1. */ +{ + Interp *iPtr = (Interp *) interp; + register Var *varPtr; + Var *arrayPtr; + Tcl_Obj *oldValuePtr; + Tcl_Obj *resultPtr = NULL; + char *part1, *bytes; + char *part2 = NULL; + int length, result; + + /* + * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. + */ + + part1 = TclGetStringFromObj(part1Ptr, (int *) NULL); + if (part2Ptr != NULL) { + part2 = TclGetStringFromObj(part2Ptr, (int *) NULL); + } + + varPtr = TclLookupVar(interp, part1, part2, flags, "set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * If the variable is in a hashtable and its hPtr field is NULL, then we + * have an upvar to an array element where the array was deleted, + * leaving the element dangling at the end of the upvar. Generate an + * error (allowing the variable to be reset would screw up our storage + * allocation and is meaningless anyway). + */ + + if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "set", danglingUpvar); + } + return NULL; + } + + /* + * It's an error to try to set an array variable itself. + */ + + if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "set", isArray); + } + return NULL; + } + + /* + * At this point, if we were appending, we used to call read traces: we + * treated append as a read-modify-write. However, it seemed unlikely to + * us that a real program would be interested in such reads being done + * during a set operation. + */ + + /* + * Set the variable's new value. If appending, append the new value to + * the variable, either as a list element or as a string. Also, if + * appending, then if the variable's old value is unshared we can modify + * it directly, otherwise we must create a new copy to modify: this is + * "copy on write". + */ + + oldValuePtr = varPtr->value.objPtr; + if (flags & TCL_APPEND_VALUE) { + if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { + Tcl_DecrRefCount(oldValuePtr); /* discard old value */ + varPtr->value.objPtr = NULL; + oldValuePtr = NULL; + } + if (flags & TCL_LIST_ELEMENT) { /* append list element */ + if (oldValuePtr == NULL) { + TclNewObj(oldValuePtr); + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is reference */ + } else if (Tcl_IsShared(oldValuePtr)) { + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + Tcl_DecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is reference */ + } + result = Tcl_ListObjAppendElement(interp, oldValuePtr, + newValuePtr); + if (result != TCL_OK) { + return NULL; + } + } else { /* append string */ + /* + * We append newValuePtr's bytes but don't change its ref count. + */ + + bytes = Tcl_GetStringFromObj(newValuePtr, &length); + if (oldValuePtr == NULL) { + varPtr->value.objPtr = Tcl_NewStringObj(bytes, length); + Tcl_IncrRefCount(varPtr->value.objPtr); + } else { + if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* since var is ref */ + } + Tcl_AppendToObj(oldValuePtr, bytes, length); + } + } + } else { + if (flags & TCL_LIST_ELEMENT) { /* set var to list element */ + int neededBytes, listFlags; + + /* + * We set the variable to the result of converting newValuePtr's + * string rep to a list element. We do not change newValuePtr's + * ref count. + */ + + if (oldValuePtr != NULL) { + Tcl_DecrRefCount(oldValuePtr); /* discard old value */ + } + bytes = Tcl_GetStringFromObj(newValuePtr, &length); + neededBytes = Tcl_ScanElement(bytes, &listFlags); + oldValuePtr = Tcl_NewObj(); + oldValuePtr->bytes = (char *) + ckalloc((unsigned) (neededBytes + 1)); + oldValuePtr->length = Tcl_ConvertElement(bytes, + oldValuePtr->bytes, listFlags); + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(varPtr->value.objPtr); + } else if (newValuePtr != oldValuePtr) { + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); /* var is another ref */ + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); /* discard old value */ + } + } + } + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + if (arrayPtr != NULL) { + TclClearVarUndefined(arrayPtr); + } + + /* + * Invoke any write traces for the variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + char *msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_WRITES); + if (msg != NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "set", msg); + } + goto cleanup; + } + } + + /* + * Return the variable's value unless the variable was changed in some + * gross way by a trace (e.g. it was unset and then recreated as an + * array). + */ + + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { + return varPtr->value.objPtr; + } + + /* + * A trace changed the value in some gross way. Return an empty string + * object. + */ + + resultPtr = iPtr->emptyObjPtr; + + /* + * If the variable doesn't exist anymore and no-one's using it, then + * free up the relevant structures and hash table entries. + */ + + cleanup: + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, arrayPtr); + } + return resultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetIndexedScalar -- + * + * Change the Tcl object value of a local scalar variable in the active + * procedure, given its compile-time allocated index in the procedure's + * array of local variables. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable given by localIndex. If the specified variable doesn't + * exist, or there is a clash in array usage, or an error occurs while + * executing variable traces, then NULL is returned and a message will + * be left in the interpreter's result if leaveErrorMsg is 1. Note + * that the returned object may not be the same one referenced by + * newValuePtr; this is because variable traces may modify the + * variable's value. + * + * Side effects: + * The value of the given variable is set. The reference count is + * decremented for any old value of the variable and incremented for + * its new value. If as a result of a variable trace the new value for + * the variable is not the same one referenced by newValuePtr, then + * newValuePtr's ref count is left unchanged. The ref count for the + * returned object is _not_ incremented to reflect the returned + * reference; if you want to keep a reference to the object you must + * increment its ref count yourself. This procedure does not create + * new variables, but only sets those recognized at compile time. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + int localIndex; /* Index of variable in procedure's array + * of local variables. */ + Tcl_Obj *newValuePtr; /* New value for variable. */ + int leaveErrorMsg; /* 1 if to leave an error message in + * the interpreter's result on an error. + * Otherwise no error message is left. */ +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + /* Points to the procedure call frame whose + * variables are currently in use. Same as + * the current procedure's frame, if any, + * unless an "uplevel" is executing. */ + Var *compiledLocals = varFramePtr->compiledLocals; + register Var *varPtr; /* Points to the variable's in-frame Var + * structure. */ + char *varName; /* Name of the local variable. */ + Tcl_Obj *oldValuePtr; + Tcl_Obj *resultPtr = NULL; + +#ifdef TCL_COMPILE_DEBUG + Proc *procPtr = varFramePtr->procPtr; + int localCt = procPtr->numCompiledLocals; + + if (compiledLocals == NULL) { + fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x, no compiled locals\n", + localIndex, (unsigned int) varFramePtr); + panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", + (unsigned int) varFramePtr); + } + if ((localIndex < 0) || (localIndex >= localCt)) { + fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x with %i locals\n", + localIndex, (unsigned int) varFramePtr, localCt); + panic("TclSetIndexedScalar: bad local index %i in frame 0x%x", + localIndex, (unsigned int) varFramePtr); + } +#endif /* TCL_COMPILE_DEBUG */ + + varPtr = &(compiledLocals[localIndex]); + varName = varPtr->name; + + /* + * If varPtr is a link variable, we have a reference to some variable + * that was created through an "upvar" or "global" command, or we have a + * reference to a variable in an enclosing namespace. Traverse through + * any links until we find the referenced variable. + */ + + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + + /* + * If the variable is in a hashtable and its hPtr field is NULL, then we + * have an upvar to an array element where the array was deleted, + * leaving the element dangling at the end of the upvar. Generate an + * error (allowing the variable to be reset would screw up our storage + * allocation and is meaningless anyway). + */ + + if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { + if (leaveErrorMsg) { + VarErrMsg(interp, varName, NULL, "set", danglingUpvar); + } + return NULL; + } + + /* + * It's an error to try to set an array variable itself. + */ + + if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + if (leaveErrorMsg) { + VarErrMsg(interp, varName, NULL, "set", isArray); + } + return NULL; + } + + /* + * Set the variable's new value and discard its old value. We don't + * append with this "set" procedure so the old value isn't needed. + */ + + oldValuePtr = varPtr->value.objPtr; + if (newValuePtr != oldValuePtr) { /* set new value */ + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); /* discard old value */ + } + } + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + + /* + * Invoke any write traces for the variable. + */ + + if (varPtr->tracePtr != NULL) { + char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, + varName, (char *) NULL, TCL_TRACE_WRITES); + if (msg != NULL) { + if (leaveErrorMsg) { + VarErrMsg(interp, varName, NULL, "set", msg); + } + goto cleanup; + } + } + + /* + * Return the variable's value unless the variable was changed in some + * gross way by a trace (e.g. it was unset and then recreated as an + * array). If it was changed is a gross way, just return an empty string + * object. + */ + + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { + return varPtr->value.objPtr; + } + + resultPtr = Tcl_NewObj(); + + /* + * If the variable doesn't exist anymore and no-one's using it, then + * free up the relevant structures and hash table entries. + */ + + cleanup: + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, NULL); + } + return resultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetElementOfIndexedArray -- + * + * Change the Tcl object value of an element in a local array + * variable. The element is named by the object elemPtr while the array + * is specified by its index in the active procedure's array of + * compiler allocated local variables. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * element. If the specified array or element doesn't exist, or there + * is a clash in array usage, or an error occurs while executing + * variable traces, then NULL is returned and a message will be left in + * the interpreter's result if leaveErrorMsg is 1. Note that the + * returned object may not be the same one referenced by newValuePtr; + * this is because variable traces may modify the variable's value. + * + * Side effects: + * The value of the given array element is set. The reference count is + * decremented for any old value of the element and incremented for its + * new value. If as a result of a variable trace the new value for the + * element is not the same one referenced by newValuePtr, then + * newValuePtr's ref count is left unchanged. The ref count for the + * returned object is _not_ incremented to reflect the returned + * reference; if you want to keep a reference to the object you must + * increment its ref count yourself. This procedure will not create new + * array variables, but only sets elements of those arrays recognized + * at compile time. However, if the entry doesn't exist then a new + * variable is created. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, + leaveErrorMsg) + Tcl_Interp *interp; /* Command interpreter in which the array is + * to be found. */ + int localIndex; /* Index of array variable in procedure's + * array of local variables. */ + Tcl_Obj *elemPtr; /* Points to an object holding the name of + * an element to set in the array. */ + Tcl_Obj *newValuePtr; /* New value for variable. */ + int leaveErrorMsg; /* 1 if to leave an error message in + * the interpreter's result on an error. + * Otherwise no error message is left. */ +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + /* Points to the procedure call frame whose + * variables are currently in use. Same as + * the current procedure's frame, if any, + * unless an "uplevel" is executing. */ + Var *compiledLocals = varFramePtr->compiledLocals; + Var *arrayPtr; /* Points to the array's in-frame Var + * structure. */ + char *arrayName; /* Name of the local array. */ + char *elem; + Tcl_HashEntry *hPtr; + Var *varPtr = NULL; /* Points to the element's Var structure + * that we return. */ + Tcl_Obj *resultPtr = NULL; + Tcl_Obj *oldValuePtr; + int new; + +#ifdef TCL_COMPILE_DEBUG + Proc *procPtr = varFramePtr->procPtr; + int localCt = procPtr->numCompiledLocals; + + if (compiledLocals == NULL) { + fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element of local %i in frame 0x%x, no compiled locals\n", + localIndex, (unsigned int) varFramePtr); + panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", + (unsigned int) varFramePtr); + } + if ((localIndex < 0) || (localIndex >= localCt)) { + fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n", + localIndex, (unsigned int) varFramePtr, localCt); + panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x", + localIndex, (unsigned int) varFramePtr); + } +#endif /* TCL_COMPILE_DEBUG */ + + /* + * THIS FAILS IF THE ELEMENT NAME OBJECT'S STRING REP HAS A NULL BYTE. + */ + + elem = Tcl_GetStringFromObj(elemPtr, (int *) NULL); + arrayPtr = &(compiledLocals[localIndex]); + arrayName = arrayPtr->name; + + /* + * If arrayPtr is a link variable, we have a reference to some variable + * that was created through an "upvar" or "global" command, or we have a + * reference to a variable in an enclosing namespace. Traverse through + * any links until we find the referenced variable. + */ + + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + + /* + * Make sure we're dealing with an array. + */ + + if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { + TclSetVarArray(arrayPtr); + arrayPtr->value.tablePtr = + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); + TclClearVarUndefined(arrayPtr); + } else if (!TclIsVarArray(arrayPtr)) { + if (leaveErrorMsg) { + VarErrMsg(interp, arrayName, elem, "set", needArray); + } + goto errorReturn; + } + + /* + * Look up the element. + */ + + hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new); + if (new) { + if (arrayPtr->searchPtr != NULL) { + DeleteSearches(arrayPtr); + } + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = varFramePtr->nsPtr; + TclSetVarArrayElement(varPtr); + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); + + /* + * It's an error to try to set an array variable itself. + */ + + if (TclIsVarArray(varPtr)) { + if (leaveErrorMsg) { + VarErrMsg(interp, arrayName, elem, "set", isArray); + } + goto errorReturn; + } + + /* + * Set the variable's new value and discard the old one. We don't + * append with this "set" procedure so the old value isn't needed. + */ + + oldValuePtr = varPtr->value.objPtr; + if (newValuePtr != oldValuePtr) { /* set new value */ + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); /* discard old value */ + } + } + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + + /* + * Invoke any write traces for the element variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, + TCL_TRACE_WRITES); + if (msg != NULL) { + if (leaveErrorMsg) { + VarErrMsg(interp, arrayName, elem, "set", msg); + } + goto errorReturn; + } + } + + /* + * Return the element's value unless it was changed in some gross way by + * a trace (e.g. it was unset and then recreated as an array). If it was + * changed is a gross way, just return an empty string object. + */ + + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { + return varPtr->value.objPtr; + } + + resultPtr = Tcl_NewObj(); + + /* + * An error. If the variable doesn't exist anymore and no-one's using + * it, then free up the relevant structures and hash table entries. + */ + + errorReturn: + if (varPtr != NULL) { + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, NULL); /* note: array isn't in hashtable */ + } + } + return resultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclIncrVar2 -- + * + * Given a two-part variable name, which may refer either to a scalar + * variable or an element of an array, increment the Tcl object value + * of the variable by a specified amount. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the specified variable doesn't exist, or there is a + * clash in array usage, or an error occurs while executing variable + * traces, then NULL is returned and a message will be left in + * the interpreter's result. + * + * Side effects: + * The value of the given variable is incremented by the specified + * amount. If either the array or the entry didn't exist then a new + * variable is created. The ref count for the returned object is _not_ + * incremented to reflect the returned reference; if you want to keep a + * reference to the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + Tcl_Obj *part1Ptr; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + long incrAmount; /* Amount to be added to variable. */ + int part1NotParsed; /* 1 if part1 hasn't yet been parsed into + * an array name and index (if any). */ +{ + register Tcl_Obj *varValuePtr; + Tcl_Obj *resultPtr; + int createdNewObj; /* Set 1 if var's value object is shared + * so we must increment a copy (i.e. copy + * on write). */ + long i; + int flags, result; + + flags = TCL_LEAVE_ERR_MSG; + if (part1NotParsed) { + flags |= TCL_PARSE_PART1; + } + + varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); + if (varValuePtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + return NULL; + } + + /* + * Increment the variable's value. If the object is unshared we can + * modify it directly, otherwise we must create a new copy to modify: + * this is "copy on write". Then free the variable's old string + * representation, if any, since it will no longer be valid. + */ + + createdNewObj = 0; + if (Tcl_IsShared(varValuePtr)) { + varValuePtr = Tcl_DuplicateObj(varValuePtr); + createdNewObj = 1; + } + result = Tcl_GetLongFromObj(interp, varValuePtr, &i); + if (result != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + Tcl_SetLongObj(varValuePtr, (i + incrAmount)); + + /* + * Store the variable's new value and run any write traces. + */ + + resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, + flags); + if (resultPtr == NULL) { + return NULL; + } + return resultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclIncrIndexedScalar -- + * + * Increments the Tcl object value of a local scalar variable in the + * active procedure, given its compile-time allocated index in the + * procedure's array of local variables. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable given by localIndex. If the specified variable doesn't + * exist, or there is a clash in array usage, or an error occurs while + * executing variable traces, then NULL is returned and a message will + * be left in the interpreter's result. + * + * Side effects: + * The value of the given variable is incremented by the specified + * amount. The ref count for the returned object is _not_ incremented + * to reflect the returned reference; if you want to keep a reference + * to the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclIncrIndexedScalar(interp, localIndex, incrAmount) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + int localIndex; /* Index of variable in procedure's array + * of local variables. */ + long incrAmount; /* Amount to be added to variable. */ +{ + register Tcl_Obj *varValuePtr; + Tcl_Obj *resultPtr; + int createdNewObj; /* Set 1 if var's value object is shared + * so we must increment a copy (i.e. copy + * on write). */ + long i; + int result; + + varValuePtr = TclGetIndexedScalar(interp, localIndex, + /*leaveErrorMsg*/ 1); + if (varValuePtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + return NULL; + } + + /* + * Reach into the object's representation to extract and increment the + * variable's value. If the object is unshared we can modify it + * directly, otherwise we must create a new copy to modify: this is + * "copy on write". Then free the variable's old string representation, + * if any, since it will no longer be valid. + */ + + createdNewObj = 0; + if (Tcl_IsShared(varValuePtr)) { + createdNewObj = 1; + varValuePtr = Tcl_DuplicateObj(varValuePtr); + } + result = Tcl_GetLongFromObj(interp, varValuePtr, &i); + if (result != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + Tcl_SetLongObj(varValuePtr, (i + incrAmount)); + + /* + * Store the variable's new value and run any write traces. + */ + + resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr, + /*leaveErrorMsg*/ 1); + if (resultPtr == NULL) { + return NULL; + } + return resultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclIncrElementOfIndexedArray -- + * + * Increments the Tcl object value of an element in a local array + * variable. The element is named by the object elemPtr while the array + * is specified by its index in the active procedure's array of + * compiler allocated local variables. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * element. If the specified array or element doesn't exist, or there + * is a clash in array usage, or an error occurs while executing + * variable traces, then NULL is returned and a message will be left in + * the interpreter's result. + * + * Side effects: + * The value of the given array element is incremented by the specified + * amount. The ref count for the returned object is _not_ incremented + * to reflect the returned reference; if you want to keep a reference + * to the object you must increment its ref count yourself. If the + * entry doesn't exist then a new variable is created. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) + Tcl_Interp *interp; /* Command interpreter in which the array is + * to be found. */ + int localIndex; /* Index of array variable in procedure's + * array of local variables. */ + Tcl_Obj *elemPtr; /* Points to an object holding the name of + * an element to increment in the array. */ + long incrAmount; /* Amount to be added to variable. */ +{ + register Tcl_Obj *varValuePtr; + Tcl_Obj *resultPtr; + int createdNewObj; /* Set 1 if var's value object is shared + * so we must increment a copy (i.e. copy + * on write). */ + long i; + int result; + + varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr, + /*leaveErrorMsg*/ 1); + if (varValuePtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + return NULL; + } + + /* + * Reach into the object's representation to extract and increment the + * variable's value. If the object is unshared we can modify it + * directly, otherwise we must create a new copy to modify: this is + * "copy on write". Then free the variable's old string representation, + * if any, since it will no longer be valid. + */ + + createdNewObj = 0; + if (Tcl_IsShared(varValuePtr)) { + createdNewObj = 1; + varValuePtr = Tcl_DuplicateObj(varValuePtr); + } + result = Tcl_GetLongFromObj(interp, varValuePtr, &i); + if (result != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + Tcl_SetLongObj(varValuePtr, (i + incrAmount)); + + /* + * Store the variable's new value and run any write traces. + */ + + resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr, + varValuePtr, + /*leaveErrorMsg*/ 1); + if (resultPtr == NULL) { + return NULL; + } + return resultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetVar -- + * + * Delete a variable, so that it may not be accessed anymore. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR + * if the variable can't be unset. In the event of an error, + * if the TCL_LEAVE_ERR_MSG flag is set then an error message + * is left in interp->result. + * + * Side effects: + * If varName is defined as a local or global variable in interp, + * it is deleted. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UnsetVar(interp, varName, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *varName; /* Name of a variable in interp. May be + * either a scalar name or an array name + * or an element in an array. */ + int flags; /* OR-ed combination of any of + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or + * TCL_LEAVE_ERR_MSG. */ +{ + return Tcl_UnsetVar2(interp, varName, (char *) NULL, + (flags | TCL_PARSE_PART1)); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetVar2 -- + * + * Delete a variable, given a 2-part name. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR + * if the variable can't be unset. In the event of an error, + * if the TCL_LEAVE_ERR_MSG flag is set then an error message + * is left in interp->result. + * + * Side effects: + * If part1 and part2 indicate a local or global variable in interp, + * it is deleted. If part1 is an array name and part2 is NULL, then + * the whole array is deleted. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UnsetVar2(interp, part1, part2, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *part1; /* Name of variable or array. */ + char *part2; /* Name of element within array or NULL. */ + int flags; /* OR-ed combination of any of + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_LEAVE_ERR_MSG, or + * TCL_PARSE_PART1. */ +{ + Var dummyVar; + Var *varPtr, *dummyVarPtr; + Interp *iPtr = (Interp *) interp; + Var *arrayPtr; + ActiveVarTrace *activePtr; + Tcl_Obj *objPtr; + int result; + + varPtr = TclLookupVar(interp, part1, part2, flags, "unset", + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); + + if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) { + DeleteSearches(arrayPtr); + } + + /* + * The code below is tricky, because of the possibility that + * a trace procedure might try to access a variable being + * deleted. To handle this situation gracefully, do things + * in three steps: + * 1. Copy the contents of the variable to a dummy variable + * structure, and mark the original Var structure as undefined. + * 2. Invoke traces and clean up the variable, using the dummy copy. + * 3. If at the end of this the original variable is still + * undefined and has no outstanding references, then delete + * it (but it could have gotten recreated by a trace). + */ + + dummyVar = *varPtr; + TclSetVarUndefined(varPtr); + TclSetVarScalar(varPtr); + varPtr->value.objPtr = NULL; /* dummyVar points to any value object */ + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + + /* + * Call trace procedures for the variable being deleted. Then delete + * its traces. Be sure to abort any other traces for the variable + * that are still pending. Special tricks: + * 1. We need to increment varPtr's refCount around this: CallTraces + * will use dummyVar so it won't increment varPtr's refCount itself. + * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to + * call unset traces even if other traces are pending. + */ + + if ((dummyVar.tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + varPtr->refCount++; + dummyVar.flags &= ~VAR_TRACE_ACTIVE; + (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_UNSETS); + while (dummyVar.tracePtr != NULL) { + VarTrace *tracePtr = dummyVar.tracePtr; + dummyVar.tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + varPtr->refCount--; + } + + /* + * If the variable is an array, delete all of its elements. This must be + * done after calling the traces on the array, above (that's the way + * traces are defined). If it is a scalar, "discard" its object + * (decrement the ref count of its object, if any). + */ + + dummyVarPtr = &dummyVar; + if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) { + DeleteArray(iPtr, part1, dummyVarPtr, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); + } + if (TclIsVarScalar(dummyVarPtr) + && (dummyVarPtr->value.objPtr != NULL)) { + objPtr = dummyVarPtr->value.objPtr; + TclDecrRefCount(objPtr); + dummyVarPtr->value.objPtr = NULL; + } + + /* + * If the variable was a namespace variable, decrement its reference + * count. We are in the process of destroying its namespace so that + * namespace will no longer "refer" to the variable. + */ + + if (varPtr->flags & VAR_NAMESPACE_VAR) { + varPtr->flags &= ~VAR_NAMESPACE_VAR; + varPtr->refCount--; + } + + /* + * It's an error to unset an undefined variable. + */ + + if (result != TCL_OK) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "unset", + ((arrayPtr == NULL) ? noSuchVar : noSuchElement)); + } + } + + /* + * Finally, if the variable is truly not in use then free up its Var + * structure and remove it from its hash table, if any. The ref count of + * its value object, if any, was decremented above. + */ + + CleanupVar(varPtr, arrayPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceVar -- + * + * Arrange for reads and/or writes to a variable to cause a + * procedure to be invoked, which can monitor the operations + * and/or change their actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by varName, such that + * future references to the variable will be intermediated by + * proc. See the manual entry for complete details on the calling + * sequence for proc. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TraceVar(interp, varName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which variable is + * to be traced. */ + char *varName; /* Name of variable; may end with "(index)" + * to signify an array reference. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are + * invoked upon varName. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + return Tcl_TraceVar2(interp, varName, (char *) NULL, + (flags | TCL_PARSE_PART1), proc, clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceVar2 -- + * + * Arrange for reads and/or writes to a variable to cause a + * procedure to be invoked, which can monitor the operations + * and/or change their actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by part1 and part2, such + * that future references to the variable will be intermediated by + * proc. See the manual entry for complete details on the calling + * sequence for proc. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which variable is + * to be traced. */ + char *part1; /* Name of scalar variable or array. */ + char *part2; /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY and + * TCL_PARSE_PART1. */ + Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are + * invoked upon varName. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + Var *varPtr, *arrayPtr; + register VarTrace *tracePtr; + + varPtr = TclLookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG), + "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + + /* + * Set up trace information. + */ + + tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = + flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); + tracePtr->nextPtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceVar -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by varName + * with the given flags, proc, and clientData, then that trace + * is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UntraceVar(interp, varName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *varName; /* Name of variable; may end with "(index)" + * to signify an array reference. */ + int flags; /* OR-ed collection of bits describing + * current trace, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY + * and TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + Tcl_UntraceVar2(interp, varName, (char *) NULL, + (flags | TCL_PARSE_PART1), proc, clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceVar2 -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by part1 + * and part2 with the given flags, proc, and clientData, then + * that trace is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *part1; /* Name of variable or array. */ + char *part2; /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags; /* OR-ed collection of bits describing + * current trace, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY and + * TCL_PARSE_PART1. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + register VarTrace *tracePtr; + VarTrace *prevPtr; + Var *varPtr, *arrayPtr; + Interp *iPtr = (Interp *) interp; + ActiveVarTrace *activePtr; + + varPtr = TclLookupVar(interp, part1, part2, + flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1), + /*msg*/ (char *) NULL, + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + if (varPtr == NULL) { + return; + } + + flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); + for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + if (tracePtr == NULL) { + return; + } + if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) + && (tracePtr->clientData == clientData)) { + break; + } + } + + /* + * The code below makes it possible to delete traces while traces + * are active: it makes sure that the deleted trace won't be + * processed by CallTraces. + */ + + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + activePtr->nextTracePtr = tracePtr->nextPtr; + } + } + if (prevPtr == NULL) { + varPtr->tracePtr = tracePtr->nextPtr; + } else { + prevPtr->nextPtr = tracePtr->nextPtr; + } + ckfree((char *) tracePtr); + + /* + * If this is the last trace on the variable, and the variable is + * unset and unused, then free up the variable. + */ + + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, (Var *) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarTraceInfo -- + * + * Return the clientData value associated with a trace on a + * variable. This procedure can also be used to step through + * all of the traces on a particular variable that have the + * same trace procedure. + * + * Results: + * The return value is the clientData value associated with + * a trace on the given variable. Information will only be + * returned for a trace with proc as trace procedure. If + * the clientData argument is NULL then the first such trace is + * returned; otherwise, the next relevant one after the one + * given by clientData will be returned. If the variable + * doesn't exist, or if there are no (more) traces for it, + * then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *varName; /* Name of variable; may end with "(index)" + * to signify an array reference. */ + int flags; /* 0, TCL_GLOBAL_ONLY, or + * TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned + * by this procedure, so this call will + * return the next trace after that one. + * If NULL, this call will return the + * first trace. */ +{ + return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, + (flags | TCL_PARSE_PART1), proc, prevClientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarTraceInfo2 -- + * + * Same as Tcl_VarTraceInfo, except takes name in two pieces + * instead of one. + * + * Results: + * Same as Tcl_VarTraceInfo. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *part1; /* Name of variable or array. */ + char *part2; /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, and + * TCL_PARSE_PART1. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned + * by this procedure, so this call will + * return the next trace after that one. + * If NULL, this call will return the + * first trace. */ +{ + register VarTrace *tracePtr; + Var *varPtr, *arrayPtr; + + varPtr = TclLookupVar(interp, part1, part2, + flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1), + /*msg*/ (char *) NULL, + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * Find the relevant trace, if any, and return its clientData. + */ + + tracePtr = varPtr->tracePtr; + if (prevClientData != NULL) { + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if ((tracePtr->clientData == prevClientData) + && (tracePtr->traceProc == proc)) { + tracePtr = tracePtr->nextPtr; + break; + } + } + } + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if (tracePtr->traceProc == proc) { + return tracePtr->clientData; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetObjCmd -- + * + * This object-based procedure is invoked to process the "unset" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UnsetObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register int i; + register char *name; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?"); + return TCL_ERROR; + } + + for (i = 1; i < objc; i++) { + /* + * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. + */ + + name = Tcl_GetStringFromObj(objv[i], (int *) NULL); + if (Tcl_UnsetVar2(interp, name, (char *) NULL, + (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendObjCmd -- + * + * This object-based procedure is invoked to process the "append" + * Tcl command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * A variable's value may be changed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_AppendObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Tcl_Obj *varValuePtr = NULL; + /* Initialized to avoid compiler + * warning. */ + int i; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); + return TCL_ERROR; + } + + if (objc == 2) { + varValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, + (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + if (varValuePtr == NULL) { + return TCL_ERROR; + } + } else { + for (i = 2; i < objc; i++) { + varValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL, + objv[i], + (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + if (varValuePtr == NULL) { + return TCL_ERROR; + } + } + } + + Tcl_SetObjResult(interp, varValuePtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LappendObjCmd -- + * + * This object-based procedure is invoked to process the "lappend" + * Tcl command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * A variable's value may be changed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LappendObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Obj *varValuePtr, *newValuePtr; + register List *listRepPtr; + register Tcl_Obj **elemPtrs; + int numElems, numRequired, createdNewObj, createVar, i, j; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); + return TCL_ERROR; + } + + if (objc == 2) { + newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, + (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + if (newValuePtr == NULL) { + /* + * The variable doesn't exist yet. Just create it with an empty + * initial value. + */ + + Tcl_Obj *nullObjPtr = Tcl_NewObj(); + newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, + nullObjPtr, (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + if (newValuePtr == NULL) { + Tcl_DecrRefCount(nullObjPtr); /* free unneeded object */ + return TCL_ERROR; + } + } + } else { + /* + * We have arguments to append. We used to call Tcl_ObjSetVar2 to + * append each argument one at a time to ensure that traces were run + * for each append step. We now append the arguments all at once + * because it's faster. Note that a read trace and a write trace for + * the variable will now each only be called once. Also, if the + * variable's old value is unshared we modify it directly, otherwise + * we create a new copy to modify: this is "copy on write". + */ + + createdNewObj = 0; + createVar = 1; + varValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, + TCL_PARSE_PART1); + if (varValuePtr == NULL) { + /* + * We couldn't read the old value: either the var doesn't yet + * exist or it's an array element. If it's new, we will try to + * create it with Tcl_ObjSetVar2 below. + */ + + char *name, *p; + int nameBytes, i; + + name = TclGetStringFromObj(objv[1], &nameBytes); + for (i = 0, p = name; i < nameBytes; i++, p++) { + if (*p == '(') { + p = (name + nameBytes-1); + if (*p == ')') { /* last char is ')' => array ref */ + createVar = 0; + } + break; + } + } + varValuePtr = Tcl_NewObj(); + createdNewObj = 1; + } else if (Tcl_IsShared(varValuePtr)) { + varValuePtr = Tcl_DuplicateObj(varValuePtr); + createdNewObj = 1; + } + + /* + * Convert the variable's old value to a list object if necessary. + */ + + if (varValuePtr->typePtr != &tclListType) { + int result = tclListType.setFromAnyProc(interp, varValuePtr); + if (result != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded obj. */ + } + return result; + } + } + listRepPtr = (List *) varValuePtr->internalRep.otherValuePtr; + elemPtrs = listRepPtr->elements; + numElems = listRepPtr->elemCount; + + /* + * If there is no room in the current array of element pointers, + * allocate a new, larger array and copy the pointers to it. + */ + + numRequired = numElems + (objc-2); + if (numRequired > listRepPtr->maxElemCount) { + int newMax = (2 * numRequired); + Tcl_Obj **newElemPtrs = (Tcl_Obj **) + ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); + + memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs, + (size_t) (numElems * sizeof(Tcl_Obj *))); + listRepPtr->maxElemCount = newMax; + listRepPtr->elements = newElemPtrs; + ckfree((char *) elemPtrs); + elemPtrs = newElemPtrs; + } + + /* + * Insert the new elements at the end of the list. + */ + + for (i = 2, j = numElems; i < objc; i++, j++) { + elemPtrs[j] = objv[i]; + Tcl_IncrRefCount(objv[i]); + } + listRepPtr->elemCount = numRequired; + + /* + * Invalidate and free any old string representation since it no + * longer reflects the list's internal representation. + */ + + Tcl_InvalidateStringRep(varValuePtr); + + /* + * Now store the list object back into the variable. If there is an + * error setting the new value, decrement its ref count if it + * was new and we didn't create the variable. + */ + + newValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL, + varValuePtr, (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + if (newValuePtr == NULL) { + if (createdNewObj && !createVar) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */ + } + return TCL_ERROR; + } + } + + /* + * Set the interpreter's object result to refer to the variable's value + * object. + */ + + Tcl_SetObjResult(interp, newValuePtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArrayObjCmd -- + * + * This object-based procedure is invoked to process the "array" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ArrayObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + /* + * The list of constants below should match the arrayOptions string array + * below. + */ + + enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, + ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, + ARRAY_STARTSEARCH}; + static char *arrayOptions[] = {"anymore", "donesearch", "exists", + "get", "names", "nextelement", "set", "size", "startsearch", + (char *) NULL}; + + Var *varPtr, *arrayPtr; + Tcl_HashEntry *hPtr; + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + int notArray; + char *varName; + int index, result; + + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * Locate the array variable (and it better be an array). + * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. + */ + + varName = TclGetStringFromObj(objv[2], (int *) NULL); + varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + + notArray = 0; + if ((varPtr == NULL) || !TclIsVarArray(varPtr) + || TclIsVarUndefined(varPtr)) { + notArray = 1; + } + + switch (index) { + case ARRAY_ANYMORE: { + ArraySearch *searchPtr; + char *searchId; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; + + if (searchPtr->nextEntry != NULL) { + varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); + if (!TclIsVarUndefined(varPtr2)) { + break; + } + } + searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); + if (searchPtr->nextEntry == NULL) { + Tcl_SetIntObj(resultPtr, 0); + return TCL_OK; + } + } + Tcl_SetIntObj(resultPtr, 1); + break; + } + case ARRAY_DONESEARCH: { + ArraySearch *searchPtr, *prevPtr; + char *searchId; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + if (searchPtr == NULL) { + return TCL_ERROR; + } + if (varPtr->searchPtr == searchPtr) { + varPtr->searchPtr = searchPtr->nextPtr; + } else { + for (prevPtr = varPtr->searchPtr; ; + prevPtr = prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } + } + } + ckfree((char *) searchPtr); + break; + } + case ARRAY_EXISTS: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + Tcl_SetIntObj(resultPtr, !notArray); + break; + } + case ARRAY_GET: { + Tcl_HashSearch search; + Var *varPtr2; + char *pattern = NULL; + char *name; + Tcl_Obj *namePtr, *valuePtr; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + if (objc == 4) { + pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); + } + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { + continue; /* element name doesn't match pattern */ + } + + namePtr = Tcl_NewStringObj(name, -1); + result = Tcl_ListObjAppendElement(interp, resultPtr, + namePtr); + if (result != TCL_OK) { + Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ + return result; + } + + valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, + TCL_LEAVE_ERR_MSG); + if (valuePtr == NULL) { + Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ + return result; + } + result = Tcl_ListObjAppendElement(interp, resultPtr, + valuePtr); + if (result != TCL_OK) { + Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ + return result; + } + } + break; + } + case ARRAY_NAMES: { + Tcl_HashSearch search; + Var *varPtr2; + char *pattern = NULL; + char *name; + Tcl_Obj *namePtr; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + if (objc == 4) { + pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); + } + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { + continue; /* element name doesn't match pattern */ + } + + namePtr = Tcl_NewStringObj(name, -1); + result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); + if (result != TCL_OK) { + Tcl_DecrRefCount(namePtr); /* free unneeded name object */ + return result; + } + } + break; + } + case ARRAY_NEXTELEMENT: { + ArraySearch *searchPtr; + char *searchId; + Tcl_HashEntry *hPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; + + hPtr = searchPtr->nextEntry; + if (hPtr == NULL) { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + return TCL_OK; + } + } else { + searchPtr->nextEntry = NULL; + } + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (!TclIsVarUndefined(varPtr2)) { + break; + } + } + Tcl_SetStringObj(resultPtr, + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1); + break; + } + case ARRAY_SET: { + Tcl_Obj **elemPtrs; + int listLen, i, result; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName list"); + return TCL_ERROR; + } + result = Tcl_ListObjGetElements(interp, objv[3], &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen & 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "list must have an even number of elements", -1); + return TCL_ERROR; + } + if (listLen > 0) { + for (i = 0; i < listLen; i += 2) { + if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], + elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + break; + } + } + return result; + } + + /* + * The list is empty make sure we have an array, or create + * one if necessary. + */ + + if (varPtr != NULL) { + if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) { + /* + * Already an array, done. + */ + + return TCL_OK; + } + if (TclIsVarArrayElement(varPtr) || + !TclIsVarUndefined(varPtr)) { + /* + * Either an array element, or a scalar: lose! + */ + + VarErrMsg(interp, varName, (char *)NULL, "array set", + needArray); + return TCL_ERROR; + } + } else { + /* + * Create variable for new array. + */ + + varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0, + /*createPart1*/ 1, /*createPart2*/ 0, + &arrayPtr); + } + TclSetVarArray(varPtr); + TclClearVarUndefined(varPtr); + varPtr->value.tablePtr = + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); + return TCL_OK; + } + case ARRAY_SIZE: { + Tcl_HashSearch search; + Var *varPtr2; + int size; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + size = 0; + if (!notArray) { + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, + &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + continue; + } + size++; + } + } + Tcl_SetIntObj(resultPtr, size); + break; + } + case ARRAY_STARTSEARCH: { + ArraySearch *searchPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); + if (varPtr->searchPtr == NULL) { + searchPtr->id = 1; + Tcl_AppendStringsToObj(resultPtr, "s-1-", varName, + (char *) NULL); + } else { + char string[20]; + + searchPtr->id = varPtr->searchPtr->id + 1; + TclFormatInt(string, searchPtr->id); + Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName, + (char *) NULL); + } + searchPtr->varPtr = varPtr; + searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, + &searchPtr->search); + searchPtr->nextPtr = varPtr->searchPtr; + varPtr->searchPtr = searchPtr; + break; + } + } + return TCL_OK; + + error: + Tcl_AppendStringsToObj(resultPtr, "\"", varName, "\" isn't an array", + (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * MakeUpvar -- + * + * This procedure does all of the work of the "global" and "upvar" + * commands. + * + * Results: + * A standard Tcl completion code. If an error occurs then an + * error message is left in iPtr->result. + * + * Side effects: + * The variable given by myName is linked to the variable in framePtr + * given by otherP1 and otherP2, so that references to myName are + * redirected to the other variable like a symbolic link. + * + *---------------------------------------------------------------------- + */ + +static int +MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) + Interp *iPtr; /* Interpreter containing variables. Used + * for error messages, too. */ + CallFrame *framePtr; /* Call frame containing "other" variable. + * NULL means use global :: context. */ + char *otherP1, *otherP2; /* Two-part name of variable in framePtr. */ + int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + * indicates scope of "other" variable. */ + char *myName; /* Name of variable which will refer to + * otherP1/otherP2. Must be a scalar. */ + int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + * indicates scope of myName. */ +{ + Tcl_HashEntry *hPtr; + Var *otherPtr, *varPtr, *arrayPtr; + CallFrame *varFramePtr; + CallFrame *savedFramePtr = NULL; /* Init. to avoid compiler warning. */ + Tcl_HashTable *tablePtr; + Namespace *nsPtr, *altNsPtr, *dummyNsPtr; + char *tail; + int new, result; + + /* + * Find "other" in "framePtr". If not looking up other in just the + * current namespace, temporarily replace the current var frame + * pointer in the interpreter in order to use TclLookupVar. + */ + + if (!(otherFlags & TCL_NAMESPACE_ONLY)) { + savedFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + } + otherPtr = TclLookupVar((Tcl_Interp *) iPtr, otherP1, otherP2, + (otherFlags | TCL_LEAVE_ERR_MSG), "access", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (!(otherFlags & TCL_NAMESPACE_ONLY)) { + iPtr->varFramePtr = savedFramePtr; + } + if (otherPtr == NULL) { + return TCL_ERROR; + } + + /* + * Now create a hashtable entry for "myName". Create it as either a + * namespace variable or as a local variable in a procedure call + * frame. Interpret myName as a namespace variable if: + * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag, + * 2) there is no active frame (we're at the global :: scope), + * 3) the active frame was pushed to define the namespace context + * for a "namespace eval" or "namespace inscope" command, + * 4) the name has namespace qualifiers ("::"s). + * If creating myName in the active procedure, look first in the + * frame's array of compiler-allocated local variables, then in its + * hashtable for runtime-created local variables. Create that + * procedure's local variable hashtable if necessary. + */ + + varFramePtr = iPtr->varFramePtr; + if ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) + || (varFramePtr == NULL) + || !varFramePtr->isProcCallFrame + || (strstr(myName, "::") != NULL)) { + result = TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName, + (Namespace *) NULL, (myFlags | TCL_LEAVE_ERR_MSG), + &nsPtr, &altNsPtr, &dummyNsPtr, &tail); + if (result != TCL_OK) { + return result; + } + if (nsPtr == NULL) { + nsPtr = altNsPtr; + } + if (nsPtr == NULL) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", + myName, "\": unknown namespace", (char *) NULL); + return TCL_ERROR; + } + + /* + * Check that we are not trying to create a namespace var linked to + * a local variable in a procedure. If we allowed this, the local + * variable in the shorter-lived procedure frame could go away + * leaving the namespace var's reference invalid. + */ + + if ((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", + myName, "\": upvar won't create namespace variable that refers to procedure variable", + (char *) NULL); + return TCL_ERROR; + } + + hPtr = Tcl_CreateHashEntry(&nsPtr->varTable, tail, &new); + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = nsPtr; + } else { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + } + } else { /* look in the call frame */ + Proc *procPtr = varFramePtr->procPtr; + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + Var *localVarPtr = varFramePtr->compiledLocals; + int nameLen = strlen(myName); + int i; + + varPtr = NULL; + for (i = 0; i < localCt; i++) { + if (!TclIsVarTemporary(localPtr)) { + char *localName = localVarPtr->name; + if ((myName[0] == localName[0]) + && (nameLen == localPtr->nameLength) + && (strcmp(myName, localName) == 0)) { + varPtr = localVarPtr; + new = 0; + break; + } + } + localVarPtr++; + localPtr = localPtr->nextPtr; + } + if (varPtr == NULL) { /* look in frame's local var hashtable */ + tablePtr = varFramePtr->varTablePtr; + if (tablePtr == NULL) { + tablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); + varFramePtr->varTablePtr = tablePtr; + } + hPtr = Tcl_CreateHashEntry(tablePtr, myName, &new); + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = varFramePtr->nsPtr; + } else { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + } + } + } + + if (!new) { + /* + * The variable already exists. Make sure this variable "varPtr" + * isn't the same as "otherPtr" (avoid circular links). Also, if + * it's not an upvar then it's an error. If it is an upvar, then + * just disconnect it from the thing it currently refers to. + */ + + if (varPtr == otherPtr) { + Tcl_SetResult((Tcl_Interp *) iPtr, + "can't upvar from variable to itself", TCL_STATIC); + return TCL_ERROR; + } + if (TclIsVarLink(varPtr)) { + Var *linkPtr = varPtr->value.linkPtr; + if (linkPtr == otherPtr) { + return TCL_OK; + } + linkPtr->refCount--; + if (TclIsVarUndefined(linkPtr)) { + CleanupVar(linkPtr, (Var *) NULL); + } + } else if (!TclIsVarUndefined(varPtr)) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, + "\" already exists", (char *) NULL); + return TCL_ERROR; + } else if (varPtr->tracePtr != NULL) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, + "\" has traces: can't use for upvar", (char *) NULL); + return TCL_ERROR; + } + } + TclSetVarLink(varPtr); + TclClearVarUndefined(varPtr); + varPtr->value.linkPtr = otherPtr; + otherPtr->refCount++; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpVar -- + * + * This procedure links one variable to another, just like + * the "upvar" command. + * + * Results: + * A standard Tcl completion code. If an error occurs then + * an error message is left in interp->result. + * + * Side effects: + * The variable in frameName whose name is given by varName becomes + * accessible under the name localName, so that references to + * localName are redirected to the other variable like a symbolic + * link. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UpVar(interp, frameName, varName, localName, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *frameName; /* Name of the frame containing the source + * variable, such as "1" or "#0". */ + char *varName; /* Name of a variable in interp to link to. + * May be either a scalar name or an + * element in an array. */ + char *localName; /* Name of link variable. */ + int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + * indicates scope of localName. */ +{ + int result; + CallFrame *framePtr; + register char *p; + + result = TclGetFrame(interp, frameName, &framePtr); + if (result == -1) { + return TCL_ERROR; + } + + /* + * Figure out whether varName is an array reference, then call + * MakeUpvar to do all the real work. + */ + + for (p = varName; *p != '\0'; p++) { + if (*p == '(') { + char *openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *openParen = '\0'; + *p = '\0'; + result = MakeUpvar((Interp *) interp, framePtr, varName, + openParen+1, 0, localName, flags); + *openParen = '('; + *p = ')'; + return result; + } + } + + scalar: + return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL, + 0, localName, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpVar2 -- + * + * This procedure links one variable to another, just like + * the "upvar" command. + * + * Results: + * A standard Tcl completion code. If an error occurs then + * an error message is left in interp->result. + * + * Side effects: + * The variable in frameName whose name is given by part1 and + * part2 becomes accessible under the name localName, so that + * references to localName are redirected to the other variable + * like a symbolic link. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UpVar2(interp, frameName, part1, part2, localName, flags) + Tcl_Interp *interp; /* Interpreter containing variables. Used + * for error messages too. */ + char *frameName; /* Name of the frame containing the source + * variable, such as "1" or "#0". */ + char *part1, *part2; /* Two parts of source variable name to + * link to. */ + char *localName; /* Name of link variable. */ + int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + * indicates scope of localName. */ +{ + int result; + CallFrame *framePtr; + + result = TclGetFrame(interp, frameName, &framePtr); + if (result == -1) { + return TCL_ERROR; + } + return MakeUpvar((Interp *) interp, framePtr, part1, part2, 0, + localName, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVariableFullName -- + * + * Given a Tcl_Var token returned by Tcl_FindNamespaceVar, this + * procedure appends to an object the namespace variable's full + * name, qualified by a sequence of parent namespace names. + * + * Results: + * None. + * + * Side effects: + * The variable's fully-qualified name is appended to the string + * representation of objPtr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_GetVariableFullName(interp, variable, objPtr) + Tcl_Interp *interp; /* Interpreter containing the variable. */ + Tcl_Var variable; /* Token for the variable returned by a + * previous call to Tcl_FindNamespaceVar. */ + Tcl_Obj *objPtr; /* Points to the object onto which the + * variable's full name is appended. */ +{ + Interp *iPtr = (Interp *) interp; + register Var *varPtr = (Var *) variable; + char *name; + + /* + * Add the full name of the containing namespace (if any), followed by + * the "::" separator, then the variable name. + */ + + if (varPtr != NULL) { + if (!TclIsVarArrayElement(varPtr)) { + if (varPtr->nsPtr != NULL) { + Tcl_AppendToObj(objPtr, varPtr->nsPtr->fullName, -1); + if (varPtr->nsPtr != iPtr->globalNsPtr) { + Tcl_AppendToObj(objPtr, "::", 2); + } + } + if (varPtr->name != NULL) { + Tcl_AppendToObj(objPtr, varPtr->name, -1); + } else if (varPtr->hPtr != NULL) { + name = Tcl_GetHashKey(varPtr->hPtr->tablePtr, varPtr->hPtr); + Tcl_AppendToObj(objPtr, name, -1); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalObjCmd -- + * + * This object-based procedure is invoked to process the "global" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GlobalObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + register Tcl_Obj *objPtr; + char *varName; + register char *tail; + int result, i; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?"); + return TCL_ERROR; + } + + /* + * If we are not executing inside a Tcl procedure, just return. + */ + + if ((iPtr->varFramePtr == NULL) + || !iPtr->varFramePtr->isProcCallFrame) { + return TCL_OK; + } + + for (i = 1; i < objc; i++) { + /* + * Make a local variable linked to its counterpart in the global :: + * namespace. + */ + + objPtr = objv[i]; + varName = Tcl_GetStringFromObj(objPtr, (int *) NULL); + + /* + * The variable name might have a scope qualifier, but the name for + * the local "link" variable must be the simple name at the tail. + */ + + for (tail = varName; *tail != '\0'; tail++) { + /* empty body */ + } + while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { + tail--; + } + if (*tail == ':') { + tail++; + } + + /* + * Link to the variable "varName" in the global :: namespace. + */ + + result = MakeUpvar(iPtr, (CallFrame *) NULL, + varName, (char *) NULL, /*otherFlags*/ TCL_GLOBAL_ONLY, + /*myName*/ tail, /*myFlags*/ 0); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VariableObjCmd -- + * + * Invoked to implement the "variable" command that creates one or more + * global variables. Handles the following syntax: + * + * variable ?name value...? name ?value? + * + * One or more variables can be created. The variables are initialized + * with the specified values. The value for the last variable is + * optional. + * + * If the variable does not exist, it is created and given the optional + * value. If it already exists, it is simply set to the optional + * value. Normally, "name" is an unqualified name, so it is created in + * the current namespace. If it includes namespace qualifiers, it can + * be created in another namespace. + * + * If the variable command is executed inside a Tcl procedure, it + * creates a local variable linked to the newly-created namespace + * variable. + * + * Results: + * Returns TCL_OK if the variable is found or created. Returns + * TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error message + * as the result in the interpreter's result object. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_VariableObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + char *varName, *tail; + Var *varPtr, *arrayPtr; + Tcl_Obj *varValuePtr; + int i, result; + + for (i = 1; i < objc; i = i+2) { + /* + * Look up each variable in the current namespace context, creating + * it if necessary. + */ + + varName = Tcl_GetStringFromObj(objv[i], (int *) NULL); + varPtr = TclLookupVar(interp, varName, (char *) NULL, + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define", + /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + + /* + * Mark the variable as a namespace variable and increment its + * reference count so that it will persist until its namespace is + * destroyed or until the variable is unset. + */ + + if (!(varPtr->flags & VAR_NAMESPACE_VAR)) { + varPtr->flags |= VAR_NAMESPACE_VAR; + varPtr->refCount++; + } + + /* + * If a value was specified, set the variable to that value. + * Otherwise, if the variable is new, leave it undefined. + * (If the variable already exists and no value was specified, + * leave its value unchanged; just create the local link if + * we're in a Tcl procedure). + */ + + if (i+1 < objc) { /* a value was specified */ + varValuePtr = Tcl_ObjSetVar2(interp, objv[i], (Tcl_Obj *) NULL, + objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); + if (varValuePtr == NULL) { + return TCL_ERROR; + } + } + + /* + * If we are executing inside a Tcl procedure, create a local + * variable linked to the new namespace variable "varName". + */ + + if ((iPtr->varFramePtr != NULL) + && iPtr->varFramePtr->isProcCallFrame) { + /* + * varName might have a scope qualifier, but the name for the + * local "link" variable must be the simple name at the tail. + */ + + for (tail = varName; *tail != '\0'; tail++) { + /* empty body */ + } + while ((tail > varName) + && ((*tail != ':') || (*(tail-1) != ':'))) { + tail--; + } + if (*tail == ':') { + tail++; + } + + /* + * Create a local link "tail" to the variable "varName" in the + * current namespace. + */ + + result = MakeUpvar(iPtr, (CallFrame *) NULL, + /*otherP1*/ varName, /*otherP2*/ (char *) NULL, + /*otherFlags*/ TCL_NAMESPACE_ONLY, + /*myName*/ tail, /*myFlags*/ 0); + if (result != TCL_OK) { + return result; + } + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpvarObjCmd -- + * + * This object-based procedure is invoked to process the "upvar" + * Tcl command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UpvarObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + CallFrame *framePtr; + char *frameSpec, *otherVarName, *myVarName; + register char *p; + int result; + + if (objc < 3) { + upvarSyntax: + Tcl_WrongNumArgs(interp, 1, objv, + "?level? otherVar localVar ?otherVar localVar ...?"); + return TCL_ERROR; + } + + /* + * Find the call frame containing each of the "other variables" to be + * linked to. FAILS IF objv[1]'s STRING REP CONTAINS NULLS. + */ + + frameSpec = Tcl_GetStringFromObj(objv[1], (int *) NULL); + result = TclGetFrame(interp, frameSpec, &framePtr); + if (result == -1) { + return TCL_ERROR; + } + objc -= result+1; + if ((objc & 1) != 0) { + goto upvarSyntax; + } + objv += result+1; + + /* + * Iterate over each (other variable, local variable) pair. + * Divide the other variable name into two parts, then call + * MakeUpvar to do all the work of linking it to the local variable. + */ + + for ( ; objc > 0; objc -= 2, objv += 2) { + myVarName = Tcl_GetStringFromObj(objv[1], (int *) NULL); + otherVarName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + for (p = otherVarName; *p != 0; p++) { + if (*p == '(') { + char *openParen = p; + + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *openParen = '\0'; + *p = '\0'; + result = MakeUpvar(iPtr, framePtr, + otherVarName, openParen+1, /*otherFlags*/ 0, + myVarName, /*flags*/ 0); + *openParen = '('; + *p = ')'; + goto checkResult; + } + } + scalar: + result = MakeUpvar(iPtr, framePtr, otherVarName, (char *) NULL, 0, + myVarName, /*flags*/ 0); + + checkResult: + if (result != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CallTraces -- + * + * This procedure is invoked to find and invoke relevant + * trace procedures associated with a particular operation on + * a variable. This procedure invokes traces both on the + * variable and on its containing array (where relevant). + * + * Results: + * The return value is NULL if no trace procedures were invoked, or + * if all the invoked trace procedures returned successfully. + * The return value is non-NULL if a trace procedure returned an + * error (in this case no more trace procedures were invoked after + * the error was returned). In this case the return value is a + * pointer to a static string describing the error. + * + * Side effects: + * Almost anything can happen, depending on trace; this procedure + * itself doesn't have any side effects. + * + *---------------------------------------------------------------------- + */ + +static char * +CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) + Interp *iPtr; /* Interpreter containing variable. */ + register Var *arrayPtr; /* Pointer to array variable that contains + * the variable, or NULL if the variable + * isn't an element of an array. */ + Var *varPtr; /* Variable whose traces are to be + * invoked. */ + char *part1, *part2; /* Variable's two-part name. */ + int flags; /* Flags passed to trace procedures: + * indicates what's happening to variable, + * plus other stuff like TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, and + * TCL_INTERP_DESTROYED. May also contain + * TCL_PARSE_PART1, which should not be + * passed through to callbacks. */ +{ + register VarTrace *tracePtr; + ActiveVarTrace active; + char *result, *openParen, *p; + Tcl_DString nameCopy; + int copiedName; + + /* + * If there are already similar trace procedures active for the + * variable, don't call them again. + */ + + if (varPtr->flags & VAR_TRACE_ACTIVE) { + return NULL; + } + varPtr->flags |= VAR_TRACE_ACTIVE; + varPtr->refCount++; + + /* + * If the variable name hasn't been parsed into array name and + * element, do it here. If there really is an array element, + * make a copy of the original name so that NULLs can be + * inserted into it to separate the names (can't modify the name + * string in place, because the string might get used by the + * callbacks we invoke). + */ + + copiedName = 0; + if (flags & TCL_PARSE_PART1) { + for (p = part1; ; p++) { + if (*p == 0) { + break; + } + if (*p == '(') { + openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p == ')') { + Tcl_DStringInit(&nameCopy); + Tcl_DStringAppend(&nameCopy, part1, (p-part1)); + part2 = Tcl_DStringValue(&nameCopy) + + (openParen + 1 - part1); + part2[-1] = 0; + part1 = Tcl_DStringValue(&nameCopy); + copiedName = 1; + } + break; + } + } + } + flags &= ~TCL_PARSE_PART1; + + /* + * Invoke traces on the array containing the variable, if relevant. + */ + + result = NULL; + active.nextPtr = iPtr->activeTracePtr; + iPtr->activeTracePtr = &active; + if (arrayPtr != NULL) { + arrayPtr->refCount++; + active.varPtr = arrayPtr; + for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + result = (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, part1, part2, flags); + if (result != NULL) { + if (flags & TCL_TRACE_UNSETS) { + result = NULL; + } else { + goto done; + } + } + } + } + + /* + * Invoke traces on the variable itself. + */ + + if (flags & TCL_TRACE_UNSETS) { + flags |= TCL_TRACE_DESTROYED; + } + active.varPtr = varPtr; + for (tracePtr = varPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + result = (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, part1, part2, flags); + if (result != NULL) { + if (flags & TCL_TRACE_UNSETS) { + result = NULL; + } else { + goto done; + } + } + } + + /* + * Restore the variable's flags, remove the record of our active + * traces, and then return. + */ + + done: + if (arrayPtr != NULL) { + arrayPtr->refCount--; + } + if (copiedName) { + Tcl_DStringFree(&nameCopy); + } + varPtr->flags &= ~VAR_TRACE_ACTIVE; + varPtr->refCount--; + iPtr->activeTracePtr = active.nextPtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * NewVar -- + * + * Create a new heap-allocated variable that will eventually be + * entered into a hashtable. + * + * Results: + * The return value is a pointer to the new variable structure. It is + * marked as a scalar variable (and not a link or array variable). Its + * value initially is NULL. The variable is not part of any hash table + * yet. Since it will be in a hashtable and not in a call frame, its + * name field is set NULL. It is initially marked as undefined. + * + * Side effects: + * Storage gets allocated. + * + *---------------------------------------------------------------------- + */ + +static Var * +NewVar() +{ + register Var *varPtr; + + varPtr = (Var *) ckalloc(sizeof(Var)); + varPtr->value.objPtr = NULL; + varPtr->name = NULL; + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE); + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ParseSearchId -- + * + * This procedure translates from a string to a pointer to an + * active array search (if there is one that matches the string). + * + * Results: + * The return value is a pointer to the array search indicated + * by string, or NULL if there isn't one. If NULL is returned, + * interp->result contains an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static ArraySearch * +ParseSearchId(interp, varPtr, varName, string) + Tcl_Interp *interp; /* Interpreter containing variable. */ + Var *varPtr; /* Array variable search is for. */ + char *varName; /* Name of array variable that search is + * supposed to be for. */ + char *string; /* String containing id of search. Must have + * form "search-num-var" where "num" is a + * decimal number and "var" is a variable + * name. */ +{ + char *end; + int id; + ArraySearch *searchPtr; + + /* + * Parse the id into the three parts separated by dashes. + */ + + if ((string[0] != 's') || (string[1] != '-')) { + syntax: + Tcl_AppendResult(interp, "illegal search identifier \"", string, + "\"", (char *) NULL); + return NULL; + } + id = strtoul(string+2, &end, 10); + if ((end == (string+2)) || (*end != '-')) { + goto syntax; + } + if (strcmp(end+1, varName) != 0) { + Tcl_AppendResult(interp, "search identifier \"", string, + "\" isn't for variable \"", varName, "\"", (char *) NULL); + return NULL; + } + + /* + * Search through the list of active searches on the interpreter + * to see if the desired one exists. + */ + + for (searchPtr = varPtr->searchPtr; searchPtr != NULL; + searchPtr = searchPtr->nextPtr) { + if (searchPtr->id == id) { + return searchPtr; + } + } + Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", + (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteSearches -- + * + * This procedure is called to free up all of the searches + * associated with an array variable. + * + * Results: + * None. + * + * Side effects: + * Memory is released to the storage allocator. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteSearches(arrayVarPtr) + register Var *arrayVarPtr; /* Variable whose searches are + * to be deleted. */ +{ + ArraySearch *searchPtr; + + while (arrayVarPtr->searchPtr != NULL) { + searchPtr = arrayVarPtr->searchPtr; + arrayVarPtr->searchPtr = searchPtr->nextPtr; + ckfree((char *) searchPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclDeleteVars -- + * + * This procedure is called to recycle all the storage space + * associated with a table of variables. For this procedure + * to work correctly, it must not be possible for any of the + * variables in the table to be accessed from Tcl commands + * (e.g. from trace procedures). + * + * Results: + * None. + * + * Side effects: + * Variables are deleted and trace procedures are invoked, if + * any are declared. + * + *---------------------------------------------------------------------- + */ + +void +TclDeleteVars(iPtr, tablePtr) + Interp *iPtr; /* Interpreter to which variables belong. */ + Tcl_HashTable *tablePtr; /* Hash table containing variables to + * delete. */ +{ + Tcl_Interp *interp = (Tcl_Interp *) iPtr; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + register Var *varPtr; + Var *linkPtr; + int flags; + ActiveVarTrace *activePtr; + Tcl_Obj *objPtr; + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + + /* + * Determine what flags to pass to the trace callback procedures. + */ + + flags = TCL_TRACE_UNSETS; + if (tablePtr == &iPtr->globalNsPtr->varTable) { + flags |= (TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY); + } else if (tablePtr == &currNsPtr->varTable) { + flags |= TCL_NAMESPACE_ONLY; + } + + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + + /* + * For global/upvar variables referenced in procedures, decrement + * the reference count on the variable referred to, and free + * the referenced variable if it's no longer needed. Don't delete + * the hash entry for the other variable if it's in the same table + * as us: this will happen automatically later on. + */ + + if (TclIsVarLink(varPtr)) { + linkPtr = varPtr->value.linkPtr; + linkPtr->refCount--; + if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) + && (linkPtr->tracePtr == NULL) + && (linkPtr->flags & VAR_IN_HASHTABLE)) { + if (linkPtr->hPtr == NULL) { + ckfree((char *) linkPtr); + } else if (linkPtr->hPtr->tablePtr != tablePtr) { + Tcl_DeleteHashEntry(linkPtr->hPtr); + ckfree((char *) linkPtr); + } + } + } + + /* + * Invoke traces on the variable that is being deleted, then + * free up the variable's space (no need to free the hash entry + * here, unless we're dealing with a global variable: the + * hash entries will be deleted automatically when the whole + * table is deleted). Note that we give CallTraces the variable's + * fully-qualified name so that any called trace procedures can + * refer to these variables being deleted. + */ + + if (varPtr->tracePtr != NULL) { + objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); /* until done with traces */ + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); + (void) CallTraces(iPtr, (Var *) NULL, varPtr, + Tcl_GetStringFromObj(objPtr, (int *) NULL), + (char *) NULL, flags); + Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ + + while (varPtr->tracePtr != NULL) { + VarTrace *tracePtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + } + + if (TclIsVarArray(varPtr)) { + DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, + flags); + varPtr->value.tablePtr = NULL; + } + if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { + objPtr = varPtr->value.objPtr; + TclDecrRefCount(objPtr); + varPtr->value.objPtr = NULL; + } + varPtr->hPtr = NULL; + varPtr->tracePtr = NULL; + TclSetVarUndefined(varPtr); + TclSetVarScalar(varPtr); + + /* + * If the variable was a namespace variable, decrement its + * reference count. We are in the process of destroying its + * namespace so that namespace will no longer "refer" to the + * variable. + */ + + if (varPtr->flags & VAR_NAMESPACE_VAR) { + varPtr->flags &= ~VAR_NAMESPACE_VAR; + varPtr->refCount--; + } + + /* + * Recycle the variable's memory space if there aren't any upvar's + * pointing to it. If there are upvars to this variable, then the + * variable will get freed when the last upvar goes away. + */ + + if (varPtr->refCount == 0) { + ckfree((char *) varPtr); /* this Var must be VAR_IN_HASHTABLE */ + } + } + Tcl_DeleteHashTable(tablePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclDeleteCompiledLocalVars -- + * + * This procedure is called to recycle storage space associated with + * the compiler-allocated array of local variables in a procedure call + * frame. This procedure resembles TclDeleteVars above except that each + * variable is stored in a call frame and not a hash table. For this + * procedure to work correctly, it must not be possible for any of the + * variable in the table to be accessed from Tcl commands (e.g. from + * trace procedures). + * + * Results: + * None. + * + * Side effects: + * Variables are deleted and trace procedures are invoked, if + * any are declared. + * + *---------------------------------------------------------------------- + */ + +void +TclDeleteCompiledLocalVars(iPtr, framePtr) + Interp *iPtr; /* Interpreter to which variables belong. */ + CallFrame *framePtr; /* Procedure call frame containing + * compiler-assigned local variables to + * delete. */ +{ + register Var *varPtr; + int flags; /* Flags passed to trace procedures. */ + Var *linkPtr; + ActiveVarTrace *activePtr; + int numLocals, i; + + flags = TCL_TRACE_UNSETS; + numLocals = framePtr->numCompiledLocals; + varPtr = framePtr->compiledLocals; + for (i = 0; i < numLocals; i++) { + /* + * For global/upvar variables referenced in procedures, decrement + * the reference count on the variable referred to, and free + * the referenced variable if it's no longer needed. Don't delete + * the hash entry for the other variable if it's in the same table + * as us: this will happen automatically later on. + */ + + if (TclIsVarLink(varPtr)) { + linkPtr = varPtr->value.linkPtr; + linkPtr->refCount--; + if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) + && (linkPtr->tracePtr == NULL) + && (linkPtr->flags & VAR_IN_HASHTABLE)) { + if (linkPtr->hPtr == NULL) { + ckfree((char *) linkPtr); + } else { + Tcl_DeleteHashEntry(linkPtr->hPtr); + ckfree((char *) linkPtr); + } + } + } + + /* + * Invoke traces on the variable that is being deleted. Then delete + * the variable's trace records. + */ + + if (varPtr->tracePtr != NULL) { + (void) CallTraces(iPtr, (Var *) NULL, varPtr, + varPtr->name, (char *) NULL, flags); + while (varPtr->tracePtr != NULL) { + VarTrace *tracePtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + } + + /* + * Now if the variable is an array, delete its element hash table. + * Otherwise, if it's a scalar variable, decrement the ref count + * of its value. + */ + + if (TclIsVarArray(varPtr) && (varPtr->value.tablePtr != NULL)) { + DeleteArray(iPtr, varPtr->name, varPtr, flags); + } + if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { + TclDecrRefCount(varPtr->value.objPtr); + varPtr->value.objPtr = NULL; + } + varPtr->hPtr = NULL; + varPtr->tracePtr = NULL; + TclSetVarUndefined(varPtr); + TclSetVarScalar(varPtr); + varPtr++; + } +} + +/* + *---------------------------------------------------------------------- + * + * DeleteArray -- + * + * This procedure is called to free up everything in an array + * variable. It's the caller's responsibility to make sure + * that the array is no longer accessible before this procedure + * is called. + * + * Results: + * None. + * + * Side effects: + * All storage associated with varPtr's array elements is deleted + * (including the array's hash table). Deletion trace procedures for + * array elements are invoked, then deleted. Any pending traces for + * array elements are also deleted. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteArray(iPtr, arrayName, varPtr, flags) + Interp *iPtr; /* Interpreter containing array. */ + char *arrayName; /* Name of array (used for trace + * callbacks). */ + Var *varPtr; /* Pointer to variable structure. */ + int flags; /* Flags to pass to CallTraces: + * TCL_TRACE_UNSETS and sometimes + * TCL_INTERP_DESTROYED, + * TCL_NAMESPACE_ONLY, or + * TCL_GLOBAL_ONLY. */ +{ + Tcl_HashSearch search; + register Tcl_HashEntry *hPtr; + register Var *elPtr; + ActiveVarTrace *activePtr; + Tcl_Obj *objPtr; + + DeleteSearches(varPtr); + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + elPtr = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) { + objPtr = elPtr->value.objPtr; + TclDecrRefCount(objPtr); + elPtr->value.objPtr = NULL; + } + elPtr->hPtr = NULL; + if (elPtr->tracePtr != NULL) { + elPtr->flags &= ~VAR_TRACE_ACTIVE; + (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName, + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags); + while (elPtr->tracePtr != NULL) { + VarTrace *tracePtr = elPtr->tracePtr; + elPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == elPtr) { + activePtr->nextTracePtr = NULL; + } + } + } + TclSetVarUndefined(elPtr); + TclSetVarScalar(elPtr); + if (elPtr->refCount == 0) { + ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */ + } + } + Tcl_DeleteHashTable(varPtr->value.tablePtr); + ckfree((char *) varPtr->value.tablePtr); +} + +/* + *---------------------------------------------------------------------- + * + * CleanupVar -- + * + * This procedure is called when it looks like it may be OK to free up + * a variable's storage. If the variable is in a hashtable, its Var + * structure and hash table entry will be freed along with those of its + * containing array, if any. This procedure is called, for example, + * when a trace on a variable deletes a variable. + * + * Results: + * None. + * + * Side effects: + * If the variable (or its containing array) really is dead and in a + * hashtable, then its Var structure, and possibly its hash table + * entry, is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +CleanupVar(varPtr, arrayPtr) + Var *varPtr; /* Pointer to variable that may be a + * candidate for being expunged. */ + Var *arrayPtr; /* Array that contains the variable, or + * NULL if this variable isn't an array + * element. */ +{ + if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0) + && (varPtr->tracePtr == NULL) + && (varPtr->flags & VAR_IN_HASHTABLE)) { + if (varPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(varPtr->hPtr); + } + ckfree((char *) varPtr); + } + if (arrayPtr != NULL) { + if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0) + && (arrayPtr->tracePtr == NULL) + && (arrayPtr->flags & VAR_IN_HASHTABLE)) { + if (arrayPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(arrayPtr->hPtr); + } + ckfree((char *) arrayPtr); + } + } +} +/* + *---------------------------------------------------------------------- + * + * VarErrMsg -- + * + * Generate a reasonable error message describing why a variable + * operation failed. + * + * Results: + * None. + * + * Side effects: + * Interp->result is reset to hold a message identifying the + * variable given by part1 and part2 and describing why the + * variable operation failed. + * + *---------------------------------------------------------------------- + */ + +static void +VarErrMsg(interp, part1, part2, operation, reason) + Tcl_Interp *interp; /* Interpreter in which to record message. */ + char *part1, *part2; /* Variable's two-part name. */ + char *operation; /* String describing operation that failed, + * e.g. "read", "set", or "unset". */ + char *reason; /* String describing why operation failed. */ +{ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't ", operation, " \"", part1, + (char *) NULL); + if (part2 != NULL) { + Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); + } + Tcl_AppendResult(interp, "\": ", reason, (char *) NULL); +} |