tclcmdmz.c

来自「tcl是工具命令语言」· C语言 代码 · 共 2,428 行 · 第 1/5 页

/* 
 * tclCmdMZ.c --
 *
 *	This file contains the top-level command routines for most of
 *	the Tcl built-in commands whose names begin with the letters
 *	M to Z.  It contains only commands in the generic core (i.e.
 *	those that don't depend much upon UNIX facilities).
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.82 2003/02/27 00:54:36 hobbs Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"

/*
 * Structure used to hold information about variable traces:
 */

typedef struct {
    int flags;			/* Operations for which Tcl command is
				 * to be invoked. */
    size_t length;		/* Number of non-NULL chars. in command. */
    char command[4];		/* Space for Tcl command to invoke.  Actual
				 * size will be as large as necessary to
				 * hold command.  This field must be the
				 * last in the structure, so that it can
				 * be larger than 4 bytes. */
} TraceVarInfo;

/*
 * Structure used to hold information about command traces:
 */

typedef struct {
    int flags;			/* Operations for which Tcl command is
				 * to be invoked. */
    size_t length;		/* Number of non-NULL chars. in command. */
    Tcl_Trace stepTrace;        /* Used for execution traces, when tracing
                                 * inside the given command */
    int startLevel;             /* Used for bookkeeping with step execution
                                 * traces, store the level at which the step
                                 * trace was invoked */
    char *startCmd;             /* Used for bookkeeping with step execution
                                 * traces, store the command name which invoked
                                 * step trace */
    int curFlags;               /* Trace flags for the current command */
    int curCode;                /* Return code for the current command */
    int refCount;               /* Used to ensure this structure is
                                 * not deleted too early.  Keeps track
                                 * of how many pieces of code have
                                 * a pointer to this structure. */
    char command[4];		/* Space for Tcl command to invoke.  Actual
				 * size will be as large as necessary to
				 * hold command.  This field must be the
				 * last in the structure, so that it can
				 * be larger than 4 bytes. */
} TraceCommandInfo;

/* 
 * Used by command execution traces.  Note that we assume in the code
 * that the first two defines are exactly 4 times the
 * 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants.
 * 
 * TCL_TRACE_ENTER_DURING_EXEC  - Trace each command inside the command
 *                                currently being traced, before execution.
 * TCL_TRACE_LEAVE_DURING_EXEC  - Trace each command inside the command
 *                                currently being traced, after execution.
 * TCL_TRACE_ANY_EXEC           - OR'd combination of all EXEC flags.
 * TCL_TRACE_EXEC_IN_PROGRESS   - The callback procedure on this trace
 *                                is currently executing.  Therefore we
 *                                don't let further traces execute.
 * TCL_TRACE_EXEC_DIRECT        - This execution trace is triggered directly
 *                                by the command being traced, not because
 *                                of an internal trace.
 * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also
 * be used in command execution traces.
 */
#define TCL_TRACE_ENTER_DURING_EXEC	4
#define TCL_TRACE_LEAVE_DURING_EXEC	8
#define TCL_TRACE_ANY_EXEC              15
#define TCL_TRACE_EXEC_IN_PROGRESS      0x10
#define TCL_TRACE_EXEC_DIRECT           0x20

/*
 * Forward declarations for procedures defined in this file:
 */

typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp,
	int optionIndex, int objc, Tcl_Obj *CONST objv[]));

Tcl_TraceTypeObjCmd TclTraceVariableObjCmd;
Tcl_TraceTypeObjCmd TclTraceCommandObjCmd;
Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd;

/* 
 * Each subcommand has a number of 'types' to which it can apply.
 * Currently 'execution', 'command' and 'variable' are the only
 * types supported.  These three arrays MUST be kept in sync!
 * In the future we may provide an API to add to the list of
 * supported trace types.
 */
static CONST char *traceTypeOptions[] = {
    "execution", "command", "variable", (char*) NULL
};
static Tcl_TraceTypeObjCmd* traceSubCmds[] = {
    TclTraceExecutionObjCmd,
    TclTraceCommandObjCmd,
    TclTraceVariableObjCmd,
};

/*
 * Declarations for local procedures to this file:
 */
static int              CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
                            Trace *tracePtr, Command *cmdPtr,
                            CONST char *command, int numChars,
                            int objc, Tcl_Obj *CONST objv[]));
static char *		TraceVarProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1, 
                            CONST char *name2, int flags));
static void		TraceCommandProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *oldName,
                            CONST char *newName, int flags));
static Tcl_CmdObjTraceProc TraceExecutionProc;

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PwdObjCmd --
 *
 *	This procedure is invoked to process the "pwd" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_PwdObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    Tcl_Obj *retVal;

    if (objc != 1) {
	Tcl_WrongNumArgs(interp, 1, objv, NULL);
	return TCL_ERROR;
    }

    retVal = Tcl_FSGetCwd(interp);
    if (retVal == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, retVal);
    Tcl_DecrRefCount(retVal);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegexpObjCmd --
 *
 *	This procedure is invoked to process the "regexp" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_RegexpObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int i, indices, match, about, offset, all, doinline, numMatchesSaved;
    int cflags, eflags, stringLength;
    Tcl_RegExp regExpr;
    Tcl_Obj *objPtr, *resultPtr;
    Tcl_RegExpInfo info;
    static CONST char *options[] = {
	"-all",		"-about",	"-indices",	"-inline",
	"-expanded",	"-line",	"-linestop",	"-lineanchor",
	"-nocase",	"-start",	"--",		(char *) NULL
    };
    enum options {
	REGEXP_ALL,	REGEXP_ABOUT,	REGEXP_INDICES,	REGEXP_INLINE,
	REGEXP_EXPANDED,REGEXP_LINE,	REGEXP_LINESTOP,REGEXP_LINEANCHOR,
	REGEXP_NOCASE,	REGEXP_START,	REGEXP_LAST
    };

    indices	= 0;
    about	= 0;
    cflags	= TCL_REG_ADVANCED;
    eflags	= 0;
    offset	= 0;
    all		= 0;
    doinline	= 0;
    
    for (i = 1; i < objc; i++) {
	char *name;
	int index;

	name = Tcl_GetString(objv[i]);
	if (name[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
		&index) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch ((enum options) index) {
	    case REGEXP_ALL: {
		all = 1;
		break;
	    }
	    case REGEXP_INDICES: {
		indices = 1;
		break;
	    }
	    case REGEXP_INLINE: {
		doinline = 1;
		break;
	    }
	    case REGEXP_NOCASE: {
		cflags |= TCL_REG_NOCASE;
		break;
	    }
	    case REGEXP_ABOUT: {
		about = 1;
		break;
	    }
	    case REGEXP_EXPANDED: {
		cflags |= TCL_REG_EXPANDED;
		break;
	    }
	    case REGEXP_LINE: {
		cflags |= TCL_REG_NEWLINE;
		break;
	    }
	    case REGEXP_LINESTOP: {
		cflags |= TCL_REG_NLSTOP;
		break;
	    }
	    case REGEXP_LINEANCHOR: {
		cflags |= TCL_REG_NLANCH;
		break;
	    }
	    case REGEXP_START: {
		if (++i >= objc) {
		    goto endOfForLoop;
		}
		if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (offset < 0) {
		    offset = 0;
		}
		break;
	    }
	    case REGEXP_LAST: {
		i++;
		goto endOfForLoop;
	    }
	}
    }

    endOfForLoop:
    if ((objc - i) < (2 - about)) {
	Tcl_WrongNumArgs(interp, 1, objv, 
	  "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
	return TCL_ERROR;
    }
    objc -= i;
    objv += i;

    if (doinline && ((objc - 2) != 0)) {
	/*
	 * User requested -inline, but specified match variables - a no-no.
	 */
	Tcl_AppendResult(interp, "regexp match variables not allowed",
		" when using -inline", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Handle the odd about case separately.
     */
    if (about) {
	regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
	if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) {
	    return TCL_ERROR;
	}
	return TCL_OK;
    }

    /*
     * Get the length of the string that we are matching against so
     * we can do the termination test for -all matches.  Do this before
     * getting the regexp to avoid shimmering problems.
     */
    objPtr = objv[1];
    stringLength = Tcl_GetCharLength(objPtr);

    regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
    if (regExpr == NULL) {
	return TCL_ERROR;
    }

    if (offset > 0) {
	/*
	 * Add flag if using offset (string is part of a larger string),
	 * so that "^" won't match.
	 */
	eflags |= TCL_REG_NOTBOL;
    }

    objc -= 2;
    objv += 2;
    resultPtr = Tcl_GetObjResult(interp);

    if (doinline) {
	/*
	 * Save all the subexpressions, as we will return them as a list
	 */
	numMatchesSaved = -1;
    } else {
	/*
	 * Save only enough subexpressions for matches we want to keep,
	 * expect in the case of -all, where we need to keep at least
	 * one to know where to move the offset.
	 */
	numMatchesSaved = (objc == 0) ? all : objc;
    }

    /*
     * The following loop is to handle multiple matches within the
     * same source string;  each iteration handles one match.  If "-all"
     * hasn't been specified then the loop body only gets executed once.
     * We terminate the loop when the starting offset is past the end of the
     * string.
     */

    while (1) {
	match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
		offset /* offset */, numMatchesSaved, eflags);

	if (match < 0) {
	    return TCL_ERROR;
	}

	if (match == 0) {
	    /*
	     * We want to set the value of the intepreter result only when
	     * this is the first time through the loop.
	     */
	    if (all <= 1) {
		/*
		 * If inlining, set the interpreter's object result to an
		 * empty list, otherwise set it to an integer object w/
		 * value 0.
		 */
		if (doinline) {
		    Tcl_SetListObj(resultPtr, 0, NULL);
		} else {
		    Tcl_SetIntObj(resultPtr, 0);
		}
		return TCL_OK;
	    }
	    break;
	}

	/*
	 * If additional variable names have been specified, return
	 * index information in those variables.
	 */

	Tcl_RegExpGetInfo(regExpr, &info);
	if (doinline) {
	    /*
	     * It's the number of substitutions, plus one for the matchVar
	     * at index 0
	     */
	    objc = info.nsubs + 1;
	}
	for (i = 0; i < objc; i++) {
	    Tcl_Obj *newPtr;

	    if (indices) {
		int start, end;
		Tcl_Obj *objs[2];

		/*
		 * Only adjust the match area if there was a match for
		 * that area.  (Scriptics Bug 4391/SF Bug #219232)
		 */
		if (i <= info.nsubs && info.matches[i].start >= 0) {
		    start = offset + info.matches[i].start;
		    end   = offset + info.matches[i].end;

		    /*
		     * Adjust index so it refers to the last character in the
		     * match instead of the first character after the match.
		     */

		    if (end >= offset) {
			end--;
		    }
		} else {
		    start = -1;
		    end   = -1;
		}

		objs[0] = Tcl_NewLongObj(start);
		objs[1] = Tcl_NewLongObj(end);

		newPtr = Tcl_NewListObj(2, objs);
	    } else {
		if (i <= info.nsubs) {
		    newPtr = Tcl_GetRange(objPtr,
			    offset + info.matches[i].start,
			    offset + info.matches[i].end - 1);
		} else {
		    newPtr = Tcl_NewObj();
		}
	    }
	    if (doinline) {
		if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
			!= TCL_OK) {
		    Tcl_DecrRefCount(newPtr);
		    return TCL_ERROR;
		}
	    } else {
		Tcl_Obj *valuePtr;
		valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
		if (valuePtr == NULL) {
		    Tcl_DecrRefCount(newPtr);
		    Tcl_AppendResult(interp, "couldn't set variable \"",
			    Tcl_GetString(objv[i]), "\"", (char *) NULL);
		    return TCL_ERROR;
		}
	    }
	}

	if (all == 0) {
	    break;
	}
	/*
	 * Adjust the offset to the character just after the last one
	 * in the matchVar and increment all to count how many times
	 * we are making a match.  We always increment the offset by at least
	 * one to prevent endless looping (as in the case:
	 * regexp -all {a*} a).  Otherwise, when we match the NULL string at
	 * the end of the input string, we will loop indefinately (because the
	 * length of the match is 0, so offset never changes).
	 */
	if (info.matches[0].end == 0) {
	    offset++;
	}
	offset += info.matches[0].end;
	all++;