tclcmdmz.c

tcl源码详细资料

#ifndef EXCLUDE_TCL

/* 
 * 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 1987-1991 Regents of the University of California
 * Permission to use, copy, modify, and distribute this
 * software and its documentation for any purpose and without
 * fee is hereby granted, provided that the above copyright
 * notice appear in all copies.  The University of California
 * makes no representations about the suitability of this
 * software for any purpose.  It is provided "as is" without
 * express or implied warranty.
 */

#include "tclInt.h"

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

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

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

static char *		TraceVarProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, char *name1, char *name2,
			    int flags));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegexpCmd --
 *
 *	This procedure is invoked to process the "regexp" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_RegexpCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int noCase = 0;
    int indices = 0;
    regexp *regexpPtr;
    char **argPtr, *string;
    int match, i;

    if (argc < 3) {
	wrongNumArgs:
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" ?-nocase? exp string ?matchVar? ?subMatchVar ",
		"subMatchVar ...?\"", (char *) NULL);
	return TCL_ERROR;
    }
    argPtr = argv+1;
    argc--;
    while ((argc > 0) && (argPtr[0][0] == '-')) {
	if (strcmp(argPtr[0], "-indices") == 0) {
	    argPtr++;
	    argc--;
	    indices = 1;
	} else if (strcmp(argPtr[0], "-nocase") == 0) {
	    argPtr++;
	    argc--;
	    noCase = 1;
	} else {
	    break;
	}
    }
    if (argc < 2) {
	goto wrongNumArgs;
    }
    regexpPtr = TclCompileRegexp(interp, argPtr[0]);
    if (regexpPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Convert the string to lower case, if desired, and perform
     * the match.
     */

    if (noCase) {
	register char *dst, *src;

	string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
	for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
	    if (isupper(*src)) {
		*dst = tolower(*src);
	    } else {
		*dst = *src;
	    }
	}
	*dst = 0;
    } else {
	string = argPtr[1];
    }
    tclRegexpError = NULL;
    match = regexec(regexpPtr, string);
    if (string != argPtr[1]) {
	ckfree(string);
    }
    if (tclRegexpError != NULL) {
	Tcl_AppendResult(interp, "error while matching pattern: ",
		tclRegexpError, (char *) NULL);
	return TCL_ERROR;
    }
    if (!match) {
	interp->result = "0";
	return TCL_OK;
    }

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

    argc -= 2;
    if (argc > NSUBEXP) {
	interp->result = "too many substring variables";
	return TCL_ERROR;
    }
    for (i = 0; i < argc; i++) {
	char *result, info[50];

	if (regexpPtr->startp[i] == NULL) {
	    if (indices) {
		result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
	    } else {
		result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
	    }
	} else {
	    if (indices) {
		sprintf(info, "%d %d", regexpPtr->startp[i] - string,
			regexpPtr->endp[i] - string - 1);
		result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
	    } else {
		char savedChar, *first, *last;

		first = argPtr[1] + (regexpPtr->startp[i] - string);
		last = argPtr[1] + (regexpPtr->endp[i] - string);
		savedChar = *last;
		*last = 0;
		result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
		*last = savedChar;
	    }
	}
	if (result == NULL) {
	    Tcl_AppendResult(interp, "couldn't set variable \"",
		    argPtr[i+2], "\"", (char *) NULL);
	    return TCL_ERROR;
	}
    }
    interp->result = "1";
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegsubCmd --
 *
 *	This procedure is invoked to process the "regsub" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_RegsubCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int noCase = 0, all = 0;
    regexp *regexpPtr;
    char *string, *p, *firstChar, *newValue, **argPtr;
    int match, result, flags;
    register char *src, c;

    if (argc < 5) {
	wrongNumArgs:
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" ?-nocase? ?-all? exp string subSpec varName\"", (char *) NULL);
	return TCL_ERROR;
    }
    argPtr = argv+1;
    argc--;
    while (argPtr[0][0] == '-') {
	if (strcmp(argPtr[0], "-nocase") == 0) {
	    argPtr++;
	    argc--;
	    noCase = 1;
	} else if (strcmp(argPtr[0], "-all") == 0) {
	    argPtr++;
	    argc--;
	    all = 1;
	} else {
	    break;
	}
    }
    if (argc != 4) {
	goto wrongNumArgs;
    }
    regexpPtr = TclCompileRegexp(interp, argPtr[0]);
    if (regexpPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Convert the string to lower case, if desired.
     */

    if (noCase) {
	register char *dst;

	string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
	for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
	    if (isupper(*src)) {
		*dst = tolower(*src);
	    } else {
		*dst = *src;
	    }
	}
	*dst = 0;
    } else {
	string = argPtr[1];
    }

    /*
     * The following loop is to handle multiple matches within the
     * same source string;  each iteration handles one match and its
     * corresponding substitution.  If "-all" hasn't been specified
     * then the loop body only gets executed once.
     */

    flags = 0;
    for (p = string; *p != 0; ) {
	tclRegexpError = NULL;
	match = regexec(regexpPtr, p);
	if (tclRegexpError != NULL) {
	    Tcl_AppendResult(interp, "error while matching pattern: ",
		    tclRegexpError, (char *) NULL);
	    result = TCL_ERROR;
	    goto done;
	}
	if (!match) {
	    break;
	}

	/*
	 * Copy the portion of the source string before the match to the
	 * result variable.
	 */
    
	src = argPtr[1] + (regexpPtr->startp[0] - string);
	c = *src;
	*src = 0;
	newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
		flags);
	*src = c;
	flags = TCL_APPEND_VALUE;
	if (newValue == NULL) {
	    cantSet:
	    Tcl_AppendResult(interp, "couldn't set variable \"",
		    argPtr[3], "\"", (char *) NULL);
	    result = TCL_ERROR;
	    goto done;
	}
    
	/*
	 * Append the subSpec argument to the variable, making appropriate
	 * substitutions.  This code is a bit hairy because of the backslash
	 * conventions and because the code saves up ranges of characters in
	 * subSpec to reduce the number of calls to Tcl_SetVar.
	 */
    
	for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
	    int index;
    
	    if (c == '&') {
		index = 0;
	    } else if (c == '\\') {
		c = src[1];
		if ((c >= '0') && (c <= '9')) {
		    index = c - '0';
		} else if ((c == '\\') || (c == '&')) {
		    *src = c;
		    src[1] = 0;
		    newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
			    TCL_APPEND_VALUE);
		    *src = '\\';
		    src[1] = c;
		    if (newValue == NULL) {
			goto cantSet;
		    }
		    firstChar = src+2;
		    src++;
		    continue;
		} else {
		    continue;
		}
	    } else {
		continue;
	    }
	    if (firstChar != src) {
		c = *src;
		*src = 0;
		newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
			TCL_APPEND_VALUE);
		*src = c;
		if (newValue == NULL) {
		    goto cantSet;
		}
	    }
	    if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)
		    && (regexpPtr->endp[index] != NULL)) {
		char *first, *last, saved;
    
		first = argPtr[1] + (regexpPtr->startp[index] - string);
		last = argPtr[1] + (regexpPtr->endp[index] - string);
		saved = *last;
		*last = 0;
		newValue = Tcl_SetVar(interp, argPtr[3], first,
			TCL_APPEND_VALUE);
		*last = saved;
		if (newValue == NULL) {
		    goto cantSet;
		}
	    }
	    if (*src == '\\') {
		src++;
	    }
	    firstChar = src+1;
	}
	if (firstChar != src) {
	    if (Tcl_SetVar(interp, argPtr[3], firstChar,
		    TCL_APPEND_VALUE) == NULL) {
		goto cantSet;
	    }
	}
	p = regexpPtr->endp[0];
	if (!all) {
	    break;
	}
    }

    /*
     * If there were no matches at all, then return a "0" result.
     */

    if (p == string) {
	interp->result = "0";
	result = TCL_OK;
	goto done;
    }

    /*
     * Copy the portion of the source string after the last match to the
     * result variable.
     */

    if (*p != 0) {
	if (Tcl_SetVar(interp, argPtr[3], p, TCL_APPEND_VALUE) == NULL) {
	    goto cantSet;
	}
    }
    interp->result = "1";
    result = TCL_OK;

    done:
    if (string != argPtr[1]) {
	ckfree(string);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RenameCmd --
 *
 *	This procedure is invoked to process the "rename" 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_RenameCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    register Command *cmdPtr;
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    int new;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" oldName newName\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (argv[2][0] == '\0') {
	if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
	    Tcl_AppendResult(interp, "can't delete \"", argv[1],
		    "\": command doesn't exist", (char *) NULL);
	    return TCL_ERROR;
	}
	return TCL_OK;
    }
    hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
    if (hPtr != NULL) {
	Tcl_AppendResult(interp, "can't rename to \"", argv[2],
		"\": command already exists", (char *) NULL);
	return TCL_ERROR;
    }
    hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);
    if (hPtr == NULL) {
	Tcl_AppendResult(interp, "can't rename \"", argv[1],
		"\":  command doesn't exist", (char *) NULL);
	return TCL_ERROR;
    }
    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
    Tcl_DeleteHashEntry(hPtr);
    hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);
    Tcl_SetHashValue(hPtr, cmdPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReturnCmd --