#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 */intTcl_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 */intTcl_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 */intTcl_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 --