#ifndef EXCLUDE_TCL/*  * tclCmdAH.c -- * *	This file contains the top-level command routines for most of *	the Tcl built-in commands whose names begin with the letters *	A to H. * * 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"/* *---------------------------------------------------------------------- * * Tcl_BreakCmd -- * *	This procedure is invoked to process the "break" 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_BreakCmd(dummy, interp, argc, argv)    ClientData dummy;			/* Not used. */    Tcl_Interp *interp;			/* Current interpreter. */    int argc;				/* Number of arguments. */    char **argv;			/* Argument strings. */{    if (argc != 1) {	Tcl_AppendResult(interp, "wrong # args: should be \"",		argv[0], "\"", (char *) NULL);	return TCL_ERROR;    }    return TCL_BREAK;}/* *---------------------------------------------------------------------- * * Tcl_CaseCmd -- * *	This procedure is invoked to process the "case" 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_CaseCmd(dummy, interp, argc, argv)    ClientData dummy;			/* Not used. */    Tcl_Interp *interp;			/* Current interpreter. */    int argc;				/* Number of arguments. */    char **argv;			/* Argument strings. */{    int i, result;    int body;    char *string;    int caseArgc, splitArgs;    char **caseArgv;    if (argc < 3) {	Tcl_AppendResult(interp, "wrong # args: should be \"",		argv[0], " string ?in? patList body ... ?default body?\"",		(char *) NULL);	return TCL_ERROR;    }    string = argv[1];    body = -1;    if (strcmp(argv[2], "in") == 0) {	i = 3;    } else {	i = 2;    }    caseArgc = argc - i;    caseArgv = argv + i;    /*     * If all of the pattern/command pairs are lumped into a single     * argument, split them out again.     */    splitArgs = 0;    if (caseArgc == 1) {	result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);	if (result != TCL_OK) {	    return result;	}	splitArgs = 1;    }    for (i = 0; i < caseArgc; i += 2) {	int patArgc, j;	char **patArgv;	register char *p;	if (i == (caseArgc-1)) {	    interp->result = "extra case pattern with no body";	    result = TCL_ERROR;	    goto cleanup;	}	/*	 * Check for special case of single pattern (no list) with	 * no backslash sequences.	 */	for (p = caseArgv[i]; *p != 0; p++) {	    if (isspace(*p) || (*p == '\\')) {		break;	    }	}	if (*p == 0) {	    if ((*caseArgv[i] == 'd')		    && (strcmp(caseArgv[i], "default") == 0)) {		body = i+1;	    }	    if (Tcl_StringMatch(string, caseArgv[i])) {		body = i+1;		goto match;	    }	    continue;	}	/*	 * Break up pattern lists, then check each of the patterns	 * in the list.	 */	result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);	if (result != TCL_OK) {	    goto cleanup;	}	for (j = 0; j < patArgc; j++) {	    if (Tcl_StringMatch(string, patArgv[j])) {		body = i+1;		break;	    }	}	ckfree((char *) patArgv);	if (j < patArgc) {	    break;	}    }    match:    if (body != -1) {	result = Tcl_Eval(interp, caseArgv[body], 0, (char **) NULL);	if (result == TCL_ERROR) {	    char msg[100];	    sprintf(msg, "\n    (\"%.50s\" arm line %d)", caseArgv[body-1],		    interp->errorLine);	    Tcl_AddErrorInfo(interp, msg);	}	goto cleanup;    }    /*     * Nothing matched:  return nothing.     */    result = TCL_OK;    cleanup:    if (splitArgs) {	ckfree((char *) caseArgv);    }    return result;}/* *---------------------------------------------------------------------- * * Tcl_CatchCmd -- * *	This procedure is invoked to process the "catch" 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_CatchCmd(dummy, interp, argc, argv)    ClientData dummy;			/* Not used. */    Tcl_Interp *interp;			/* Current interpreter. */    int argc;				/* Number of arguments. */    char **argv;			/* Argument strings. */{    int result;    if ((argc != 2) && (argc != 3)) {	Tcl_AppendResult(interp, "wrong # args: should be \"",		argv[0], " command ?varName?\"", (char *) NULL);	return TCL_ERROR;    }    result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);    if (argc == 3) {	if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {	    Tcl_SetResult(interp, "couldn't save command result in variable",		    TCL_STATIC);	    return TCL_ERROR;	}    }    Tcl_ResetResult(interp);    sprintf(interp->result, "%d", result);    return TCL_OK;}/* *---------------------------------------------------------------------- * * Tcl_ConcatCmd -- * *	This procedure is invoked to process the "concat" 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_ConcatCmd(dummy, interp, argc, argv)    ClientData dummy;			/* Not used. */    Tcl_Interp *interp;			/* Current interpreter. */    int argc;				/* Number of arguments. */    char **argv;			/* Argument strings. */{    if (argc == 1) {	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		" arg ?arg ...?\"", (char *) NULL);	return TCL_ERROR;    }    interp->result = Tcl_Concat(argc-1, argv+1);    interp->freeProc = (Tcl_FreeProc *) free;    return TCL_OK;}/* *---------------------------------------------------------------------- * * Tcl_ContinueCmd -- * *	This procedure is invoked to process the "continue" 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_ContinueCmd(dummy, interp, argc, argv)    ClientData dummy;			/* Not used. */    Tcl_Interp *interp;			/* Current interpreter. */    int argc;				/* Number of arguments. */    char **argv;			/* Argument strings. */{    if (argc != 1) {	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		"\"", (char *) NULL);	return TCL_ERROR;    }    return TCL_CONTINUE;}/* *---------------------------------------------------------------------- * * Tcl_ErrorCmd -- * *	This procedure is invoked to process the "error" 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_ErrorCmd(dummy, interp, argc, argv)    ClientData dummy;			/* Not used. */    Tcl_Interp *interp;			/* Current interpreter. */    int argc;				/* Number of arguments. */    char **argv;			/* Argument strings. */{    Interp *iPtr = (Interp *) interp;    if ((argc < 2) || (argc > 4)) {	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		" message ?errorInfo? ?errorCode?\"", (char *) NULL);	return TCL_ERROR;    }    if ((argc >= 3) && (argv[2][0] != 0)) {	Tcl_AddErrorInfo(interp, argv[2]);	iPtr->flags |= ERR_ALREADY_LOGGED;    }    if (argc == 4) {	Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],		TCL_GLOBAL_ONLY);	iPtr->flags |= ERROR_CODE_SET;    }    Tcl_SetResult(interp, argv[1], TCL_VOLATILE);    return TCL_ERROR;}/* *---------------------------------------------------------------------- * * Tcl_EvalCmd -- * *	This procedure is invoked to process the "eval" 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_EvalCmd(dummy, interp, argc, argv)    ClientData dummy;			/* Not used. */    Tcl_Interp *interp;			/* Current interpreter. */    int argc;				/* Number of arguments. */    char **argv;			/* Argument strings. */{    int result;    char *cmd;    if (argc < 2) {	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		" arg ?arg ...?\"", (char *) NULL);	return TCL_ERROR;    }    if (argc == 2) {	result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);    } else {    	/*	 * More than one argument:  concatenate them together with spaces	 * between, then evaluate the result.	 */    	cmd = Tcl_Concat(argc-1, argv+1);	result = Tcl_Eval(interp, cmd, 0, (char **) NULL);	ckfree(cmd);    }    if (result == TCL_ERROR) {	char msg[60];	sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);	Tcl_AddErrorInfo(interp, msg);    }    return result;}/* *---------------------------------------------------------------------- * * Tcl_ExprCmd -- * *	This procedure is invoked to process the "expr" 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_ExprCmd(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],		" expression\"", (char *) NULL);	return TCL_ERROR;    }    return Tcl_ExprString(interp, argv[1]);}/* *---------------------------------------------------------------------- * * Tcl_ForCmd -- * *	This procedure is invoked to process the "for" Tcl command. *	See the user documentation for details on what it does. * * Results: *	A standard Tcl result. * * Side effects: *	See the user documentation. * *---------------------------------------------------------------------- */	/* ARGSUSED */