Tcl Source Code

 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 */

#include "regguts.h"

/* unknown-error explanation */
static CONST char unk[] = "*** unknown regex error code 0x%x ***";

/* struct to map among codes, code names, and explanations */
static struct rerr {
	int code;
	char *name;
	char *explain;
} rerrs[] = {

extern TclStubs tclStubs;

/*
 * The following structure defines the commands in the Tcl core.
 */

typedef struct {
    CONST char *name;		/* Name of object-based command. */
    Tcl_CmdProc *proc;		/* String-based procedure for command. */
    Tcl_ObjCmdProc *objProc;	/* Object-based procedure for command. */
    CompileProc *compileProc;	/* Procedure called to compile command. */
    int isSafe;			/* If non-zero, command will be present
                                 * in safe interpreter. Otherwise it will
                                 * be hidden. */
} CmdInfo;

/*
 * The built-in commands, and the procedures that implement them:
 */

static CONST CmdInfo builtInCmds[] = {
    /*
     * Commands in the generic core. Note that at least one of the proc or
     * objProc members should be non-NULL. This avoids infinitely recursive
     * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a
     * command name is computed at runtime and results in the name of a
     * compiled command.
     */

{
    Interp *iPtr;
    Tcl_Interp *interp;
    Command *cmdPtr;
    BuiltinFunc *builtinFuncPtr;
    MathFunc *mathFuncPtr;
    Tcl_HashEntry *hPtr;
    CONST CmdInfo *cmdInfoPtr;
    int i;
    union {
	char c[sizeof(short)];
	short s;
    } order;
#ifdef TCL_COMPILE_STATS
    ByteCodeStats *statsPtr;

 *----------------------------------------------------------------------
 */

int
TclHideUnsafeCommands(interp)
    Tcl_Interp *interp;		/* Hide commands in this interpreter. */
{
    register CONST CmdInfo *cmdInfoPtr;

    if (interp == (Tcl_Interp *) NULL) {
        return TCL_ERROR;
    }
    for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
        if (!cmdInfoPtr->isSafe) {
            Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);

			break;
		    }
		    case 'h':
		    case 'H': {
			char *dest;
			unsigned char *src;
			int i;
			static CONST char hexdigit[] = "0123456789abcdef";

			if (arg >= objc) {
			    DeleteScanNumberCache(numberCachePtr);
			    goto badIndex;
			}
			if (count == BINARY_ALL) {
			    count = (length - offset)*2;

    Tcl_EncodingType encType;

    /*
     * Speed over memory. Use a full 256 character table to decode hex
     * sequences in the encoding files.
     */

    static CONST char staticHex[] = {
      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*   0 ...  15 */
      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*  16 ...  31 */
      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*  32 ...  47 */
      0,  1,  2,  3,  4,  5,  6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /*  48 ...  63 */
      0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*  64 ...  79 */
      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*  80 ...  95 */
      0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*  96 ... 111 */

/*
 * Mapping from expression instruction opcodes to strings; used for error
 * messages. Note that these entries must match the order and number of the
 * expression opcodes (e.g., INST_LOR) in tclCompile.h.
 */

static CONST char *CONST operatorStrings[] = {
    "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
    "+", "-", "*", "/", "%", "+", "-", "~", "!",
    "BUILTIN FUNCTION", "FUNCTION",
    "", "", "", "", "", "", "", "", "eq", "ne",
};

/*
 * Mapping from Tcl result codes to strings; used for error and debugging
 * messages. 
 */

#ifdef TCL_COMPILE_DEBUG
static CONST char *CONST resultStrings[] = {
    "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
};
#endif

/*
 * These are used by evalstats to monitor object usage in Tcl.
 */

static void		IllegalExprOperandType _ANSI_ARGS_((
			    Tcl_Interp *interp, unsigned char *pc,
			    Tcl_Obj *opndPtr));
static void		InitByteCodeExecution _ANSI_ARGS_((
			    Tcl_Interp *interp));
#ifdef TCL_COMPILE_DEBUG
static void		PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
static CONST char *	StringForResultCode _ANSI_ARGS_((int result));
static void		ValidatePcAndStackTop _ANSI_ARGS_((
			    ByteCode *codePtr, unsigned char *pc,
			    int stackTop, int stackLowerBound));
#endif /* TCL_COMPILE_DEBUG */
static int		VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static CONST char *
StringForResultCode(result)
    int result;			/* The Tcl result code for which to
				 * generate a string. */
{
    static char buf[TCL_INTEGER_SPACE];
    
    if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {

			}
			if (repair >= 0) {
			    Tcl_Obj *paths = Tcl_GetObjResult(interp);
			    int end;

			    Tcl_ListObjLength(NULL, paths, &end);
			    while (repair < end) {
				CONST char *bytes;
				int numBytes;
				Tcl_Obj *fixme, *newObj;
				Tcl_ListObjIndex(NULL, paths, repair, &fixme);
				bytes = Tcl_GetStringFromObj(fixme, &numBytes);
				newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
				Tcl_ListObjReplace(NULL, paths, repair, 1,
					1, &newObj);

#define STRNEQ		35

/*
 * Mapping from lexemes to strings; used for debugging messages. These
 * entries must match the order and number of the lexeme definitions above.
 */

static CONST char *CONST lexemeStrings[] = {
    "LITERAL", "FUNCNAME",
    "[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN", "UNKNOWN_CHAR",
    "*", "/", "%", "+", "-",
    "<<", ">>", "<", ">", "<=", ">=", "==", "!=",
    "&", "^", "|", "&&", "||", "?", ":",
    "!", "~", "eq", "ne",
};

static int		SomeRequirementSatisfied(char *havei, int reqc,
			    Tcl_Obj *CONST reqv[]);
static void		AddRequirementsToResult(Tcl_Interp* interp, int reqc,
			    Tcl_Obj *CONST reqv[]);
static void		AddRequirementsToDString(Tcl_DString* dstring,
			    int reqc, Tcl_Obj *CONST reqv[]);
static Package *	FindPackage(Tcl_Interp *interp, CONST char *name);
static CONST char *	PkgRequireCore(Tcl_Interp *interp, CONST char *name,
			    int reqx, Tcl_Obj *CONST reqv[],
			    ClientData *clientDataPtr);
#endif

/*
 * Helper macros.
 */

    Package *pkgPtr;
    PkgAvail *availPtr, *bestPtr;
    char *script;
    int code, satisfies, result, pass;
    Tcl_DString command;
#else
    Tcl_Obj *ov;
    CONST char *result = NULL;
#endif

    /*
     * If an attempt is being made to load this into a standalone executable
     * on a platform where backlinking is not supported then this must be
     * a shared version of Tcl (Otherwise the load would have failed).
     * Detect this situation by checking that this library has been correctly

     CONST char *name,		/* Name of desired package. */
     int reqc,                  /* Requirements constraining the desired
				 * version. */
     Tcl_Obj *CONST reqv[],     /* 0 means to use the latest version
				 * available. */
     ClientData *clientDataPtr)
{
    CONST char *result =
	    PkgRequireCore(interp, name, reqc, reqv, clientDataPtr);

    if (result == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
    return TCL_OK;
}

static CONST char *
PkgRequireCore(
     Tcl_Interp *interp,	/* Interpreter in which package is now
				 * available. */
     CONST char *name,		/* Name of desired package. */
     int reqc,                  /* Requirements constraining the desired
				 * version. */
     Tcl_Obj *CONST reqv[],     /* 0 means to use the latest version

	    if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
		Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
	    }
	}
	break;
    }
    case PKG_PRESENT: {
	CONST char *name;
	if (objc < 3) {
	    goto require;
	}
	argv2 = Tcl_GetString(objv[2]);
	if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
	    if (objc != 5) {
		goto requireSyntax;

	typePtr->freeIntRepProc(objPtr);
    }
    SetUnicodeObj(objPtr, unicode, numChars);
}

static int
UnicodeLength(
    CONST Tcl_UniChar *unicode)
{
    int numChars = 0;

    if (unicode) {
	while (numChars >= 0 && unicode[numChars] != 0) {
	    numChars++;
	}

#elif !defined(__WIN32__) /* UNIX and MAC */
#   define TclWinConvertError (void (*) _ANSI_ARGS_((unsigned int))) TclGetAndDetachPids
#   define TclWinConvertWSAError (void (*) _ANSI_ARGS_((unsigned int))) TclpCloseFile
#   define TclWinGetPlatformId (int (*)()) TclpCreateTempFile
#   define TclWinGetTclInstance (void *(*)()) TclpCreateProcess
#   define TclWinNToHS (unsigned short (*) _ANSI_ARGS_((unsigned short ns))) TclpMakeFile
#   define TclWinSetSockOpt (int (*) _ANSI_ARGS_((void *, int, int, CONST char *, int))) TclpOpenFile
#   define TclWinAddProcess 0
#   define TclWinNoBackslash 0
#   define TclWinSetInterfaces 0
#   define TclWinFlushDirtyChannels 0
#   define TclWinResetInterfaces 0
#   define TclMacOSXGetFileAttribute 0 /* Only implemented in Tcl >= 8.5 */
#   define TclMacOSXMatchType 0 /* Only implemented in Tcl >= 8.5 */

#include "tclInt.h"

/*
 * name and version of this package
 */

static CONST char packageName[] = "procbodytest";
static CONST char packageVersion[] = "1.0";

/*
 * Name of the commands exported by this package
 */

static CONST char procCommand[] = "proc";

/*
 * this struct describes an entry in the table of command names and command
 * procs
 */

typedef struct CmdTable
{
    CONST char *cmdName;	/* command name */
    Tcl_ObjCmdProc *proc;	/* command proc */
    int exportIt;		/* if 1, export the command */
} CmdTable;

/*
 * Declarations for functions defined in this file.
 */

static int	ProcBodyTestProcObjCmd _ANSI_ARGS_((ClientData dummy,
			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int	ProcBodyTestInitInternal _ANSI_ARGS_((Tcl_Interp *interp,
			int isSafe));
static int	RegisterCommand _ANSI_ARGS_((Tcl_Interp* interp,
			CONST char *namespace, CONST CmdTable *cmdTablePtr));
int             Procbodytest_Init _ANSI_ARGS_((Tcl_Interp * interp));
int             Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp * interp));

/*
 * List of commands to create when the package is loaded; must go after the
 * declarations of the enable command procedure.
 */

 *
 *----------------------------------------------------------------------
 */

static int RegisterCommand(interp, namespace, cmdTablePtr)
    Tcl_Interp* interp;			/* the Tcl interpreter for which the
                                         * operation is performed */
    CONST char *namespace;		/* the namespace in which the command
                                         * is registered */
    CONST CmdTable *cmdTablePtr;	/* the command to register */
{
    char buf[128];

    if (cmdTablePtr->exportIt) {
        sprintf(buf, "namespace eval %s { namespace export %s }",