summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorcvs2fossil <cvs2fossil>1999-02-19 02:17:04 (GMT)
committercvs2fossil <cvs2fossil>1999-02-19 02:17:04 (GMT)
commitc78065296b1912e5d37bfdf52a39f33b1b1ad6e8 (patch)
tree87ec50b593f8b962e619e10d77b9322ad677da11 /generic
parentc1ea1fac3d9e8068d1921cfc1dad655ef1d5af0c (diff)
downloadtcl-scriptics_tclpro_1_2.zip
tcl-scriptics_tclpro_1_2.tar.gz
tcl-scriptics_tclpro_1_2.tar.bz2
Created branch scriptics-tclpro-1-2-syntheticscriptics_tclpro_1_2scriptics_tclpro_1_2_synthetic
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.h1580
-rw-r--r--generic/tclFCmd.c816
-rw-r--r--generic/tclIO.c6053
-rw-r--r--generic/tclIOUtil.c872
-rw-r--r--generic/tclInt.h2147
-rw-r--r--generic/tclParse.c938
-rw-r--r--generic/tclTest.c3096
-rw-r--r--generic/tclUtil.c2843
8 files changed, 0 insertions, 18345 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
deleted file mode 100644
index 77b25e5..0000000
--- a/generic/tcl.h
+++ /dev/null
@@ -1,1580 +0,0 @@
-/*
- * 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-1999 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: tcl.h,v 1.33 1999/02/03 02:58:25 stanton Exp $
- */
-
-#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
- * mac/README
- *
- * 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 5
-
-#define TCL_VERSION "8.0"
-#define TCL_PATCH_LEVEL "8.0.5"
-
-/*
- * 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
-
-/*
- * Under Windows we need to call Tcl_Alloc in all cases to avoid competing
- * C run-time library issues.
- */
-
-# 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
-# if defined(_MSC_VER) || (defined(__GNUC__) && defined(__declspec))
-# 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
-
-/*
- * If USE_TCLALLOC is true, then we need to call Tcl_Alloc instead of
- * the native malloc/free. The only time USE_TCLALLOC should not be
- * true is when compiling the Tcl/Tk libraries on Unix systems. In this
- * case we can safely call the native malloc/free directly as a performance
- * optimization.
- */
-
-# 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 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));
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS
-
-/*
- * Convenience declaration of Tcl_AppInit for backwards compatibility.
- * This function is not *implemented* by the tcl library, so the storage
- * class is neither DLLEXPORT nor DLLIMPORT
- */
-
-EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp));
-
-#endif /* RESOURCE_INCLUDED */
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLIMPORT
-
-#endif /* _TCL */
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
deleted file mode 100644
index 1d4ae62..0000000
--- a/generic/tclFCmd.c
+++ /dev/null
@@ -1,816 +0,0 @@
-/*
- * 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: tclFCmd.c,v 1.3 1998/09/14 18:39:59 stanton Exp $
- */
-
-#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/generic/tclIO.c b/generic/tclIO.c
deleted file mode 100644
index 9725902..0000000
--- a/generic/tclIO.c
+++ /dev/null
@@ -1,6053 +0,0 @@
-/*
- * 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: tclIO.c,v 1.5 1998/10/30 00:38:38 welch Exp $
- */
-
-#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/generic/tclIOUtil.c b/generic/tclIOUtil.c
deleted file mode 100644
index c02738e..0000000
--- a/generic/tclIOUtil.c
+++ /dev/null
@@ -1,872 +0,0 @@
-/*
- * 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: tclIOUtil.c,v 1.5 1998/09/14 18:40:00 stanton Exp $
- */
-
-#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/generic/tclInt.h b/generic/tclInt.h
deleted file mode 100644
index 48d4018..0000000
--- a/generic/tclInt.h
+++ /dev/null
@@ -1,2147 +0,0 @@
-/*
- * 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-1999 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: tclInt.h,v 1.23 1999/02/03 21:28:00 stanton Exp $
- */
-
-#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_OpenObjCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-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/generic/tclParse.c b/generic/tclParse.c
deleted file mode 100644
index b822c24..0000000
--- a/generic/tclParse.c
+++ /dev/null
@@ -1,938 +0,0 @@
-/*
- * 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: tclParse.c,v 1.2 1998/09/14 18:40:01 stanton Exp $
- */
-
-#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/generic/tclTest.c b/generic/tclTest.c
deleted file mode 100644
index 23dc31f..0000000
--- a/generic/tclTest.c
+++ /dev/null
@@ -1,3096 +0,0 @@
-/*
- * 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: tclTest.c,v 1.8 1999/02/03 02:58:25 stanton Exp $
- */
-
-#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 TestsetCmd _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, this declaration
- * explicitly does not use EXTERN since this code does not get compiled
- * into the library:
- */
-
-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", TestsetCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
- (ClientData) TCL_LEAVE_ERR_MSG, (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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TestsetCmd --
- *
- * Implements the "testset{err,noerr}" cmds that are used when testing
- * Tcl_Set/GetVar C Api with/without TCL_LEAVE_ERR_MSG flag
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Variables may be set.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-TestsetCmd(data, interp, argc, argv)
- ClientData data; /* Additional flags for Get/SetVar2. */
- register Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
-{
- int flags = (int) data;
- char *value;
-
- if (argc == 2) {
- Tcl_SetResult(interp, "before get", TCL_STATIC);
- value = Tcl_GetVar2(interp, argv[1], (char *) NULL,
- TCL_PARSE_PART1|flags);
- if (value == NULL) {
- return TCL_ERROR;
- }
- Tcl_AppendElement(interp, value);
- return TCL_OK;
- } else if (argc == 3) {
- Tcl_SetResult(interp, "before set", TCL_STATIC);
- value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2],
- TCL_PARSE_PART1|flags);
- if (value == NULL) {
- return TCL_ERROR;
- }
- Tcl_AppendElement(interp, value);
- 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/generic/tclUtil.c b/generic/tclUtil.c
deleted file mode 100644
index bdbac1c..0000000
--- a/generic/tclUtil.c
+++ /dev/null
@@ -1,2843 +0,0 @@
-/*
- * 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: tclUtil.c,v 1.3 1998/09/14 18:40:02 stanton Exp $
- */
-
-#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);
-}