home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tcl7.4 / tclBasic.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-29  |  38.4 KB  |  1,448 lines
  1. /* 
  2.  * tclBasic.c --
  3.  *
  4.  *    Contains the basic facilities for TCL command interpretation,
  5.  *    including interpreter creation and deletion, command creation
  6.  *    and deletion, and command parsing and execution.
  7.  *
  8.  * Copyright (c) 1987-1994 The Regents of the University of California.
  9.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  */
  14.  
  15. static char sccsid[] = "@(#) tclBasic.c 1.168 95/06/29 13:33:21";
  16.  
  17. #include "tclInt.h"
  18. #ifndef TCL_GENERIC_ONLY
  19. #   include "tclPort.h"
  20. #endif
  21. #include "patchlevel.h"
  22.  
  23. /*
  24.  * The following variable holds the name of a user-specific startup script
  25.  * to source if the application is being run nteractively (e.g. "~/.tclshrc").
  26.  * Set by Tcl_AppInit.  NULL means don't source anything ever.
  27.  */
  28.  
  29. char *tcl_RcFileName = NULL;
  30.  
  31. /*
  32.  * The following structure defines all of the commands in the Tcl core,
  33.  * and the C procedures that execute them.
  34.  */
  35.  
  36. typedef struct {
  37.     char *name;            /* Name of command. */
  38.     Tcl_CmdProc *proc;        /* Procedure that executes command. */
  39. } CmdInfo;
  40.  
  41. /*
  42.  * Built-in commands, and the procedures associated with them:
  43.  */
  44.  
  45. static CmdInfo builtInCmds[] = {
  46.     /*
  47.      * Commands in the generic core:
  48.      */
  49.  
  50.     {"append",        Tcl_AppendCmd},
  51.     {"array",        Tcl_ArrayCmd},
  52.     {"break",        Tcl_BreakCmd},
  53.     {"case",        Tcl_CaseCmd},
  54.     {"catch",        Tcl_CatchCmd},
  55.     {"concat",        Tcl_ConcatCmd},
  56.     {"continue",    Tcl_ContinueCmd},
  57.     {"error",        Tcl_ErrorCmd},
  58.     {"eval",        Tcl_EvalCmd},
  59.     {"expr",        Tcl_ExprCmd},
  60.     {"for",        Tcl_ForCmd},
  61.     {"foreach",        Tcl_ForeachCmd},
  62.     {"format",        Tcl_FormatCmd},
  63.     {"global",        Tcl_GlobalCmd},
  64.     {"history",        Tcl_HistoryCmd},
  65.     {"if",        Tcl_IfCmd},
  66.     {"incr",        Tcl_IncrCmd},
  67.     {"info",        Tcl_InfoCmd},
  68.     {"join",        Tcl_JoinCmd},
  69.     {"lappend",        Tcl_LappendCmd},
  70.     {"lindex",        Tcl_LindexCmd},
  71.     {"linsert",        Tcl_LinsertCmd},
  72.     {"list",        Tcl_ListCmd},
  73.     {"llength",        Tcl_LlengthCmd},
  74.     {"lrange",        Tcl_LrangeCmd},
  75.     {"lreplace",    Tcl_LreplaceCmd},
  76.     {"lsearch",        Tcl_LsearchCmd},
  77.     {"lsort",        Tcl_LsortCmd},
  78.     {"proc",        Tcl_ProcCmd},
  79.     {"regexp",        Tcl_RegexpCmd},
  80.     {"regsub",        Tcl_RegsubCmd},
  81.     {"rename",        Tcl_RenameCmd},
  82.     {"return",        Tcl_ReturnCmd},
  83.     {"scan",        Tcl_ScanCmd},
  84.     {"set",        Tcl_SetCmd},
  85.     {"split",        Tcl_SplitCmd},
  86.     {"string",        Tcl_StringCmd},
  87.     {"subst",        Tcl_SubstCmd},
  88.     {"switch",        Tcl_SwitchCmd},
  89.     {"trace",        Tcl_TraceCmd},
  90.     {"unset",        Tcl_UnsetCmd},
  91.     {"uplevel",        Tcl_UplevelCmd},
  92.     {"upvar",        Tcl_UpvarCmd},
  93.     {"while",        Tcl_WhileCmd},
  94.  
  95.     /*
  96.      * Commands in the UNIX core:
  97.      */
  98.  
  99. #ifndef TCL_GENERIC_ONLY
  100.     {"cd",        Tcl_CdCmd},
  101.     {"close",        Tcl_CloseCmd},
  102.     {"eof",        Tcl_EofCmd},
  103.     {"exec",        Tcl_ExecCmd},
  104.     {"exit",        Tcl_ExitCmd},
  105.     {"file",        Tcl_FileCmd},
  106.     {"flush",        Tcl_FlushCmd},
  107.     {"gets",        Tcl_GetsCmd},
  108.     {"glob",        Tcl_GlobCmd},
  109.     {"open",        Tcl_OpenCmd},
  110.     {"pid",        Tcl_PidCmd},
  111.     {"puts",        Tcl_PutsCmd},
  112.     {"pwd",        Tcl_PwdCmd},
  113.     {"read",        Tcl_ReadCmd},
  114.     {"seek",        Tcl_SeekCmd},
  115.     {"source",        Tcl_SourceCmd},
  116.     {"tell",        Tcl_TellCmd},
  117.     {"time",        Tcl_TimeCmd},
  118. #endif /* TCL_GENERIC_ONLY */
  119.     {NULL,        (Tcl_CmdProc *) NULL}
  120. };
  121.  
  122. /*
  123.  *----------------------------------------------------------------------
  124.  *
  125.  * Tcl_CreateInterp --
  126.  *
  127.  *    Create a new TCL command interpreter.
  128.  *
  129.  * Results:
  130.  *    The return value is a token for the interpreter, which may be
  131.  *    used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
  132.  *    Tcl_DeleteInterp.
  133.  *
  134.  * Side effects:
  135.  *    The command interpreter is initialized with an empty variable
  136.  *    table and the built-in commands.  SIGPIPE signals are set to
  137.  *    be ignored (see comment below for details).
  138.  *
  139.  *----------------------------------------------------------------------
  140.  */
  141.  
  142. Tcl_Interp *
  143. Tcl_CreateInterp()
  144. {
  145.     register Interp *iPtr;
  146.     register Command *cmdPtr;
  147.     register CmdInfo *cmdInfoPtr;
  148.     int i;
  149.     char *libDir;
  150.     static int firstInterp = 1;
  151.  
  152.     iPtr = (Interp *) ckalloc(sizeof(Interp));
  153.     iPtr->result = iPtr->resultSpace;
  154.     iPtr->freeProc = 0;
  155.     iPtr->errorLine = 0;
  156.     Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS);
  157.     Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
  158.     Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS);
  159.     iPtr->numLevels = 0;
  160.     iPtr->maxNestingDepth = 1000;
  161.     iPtr->framePtr = NULL;
  162.     iPtr->varFramePtr = NULL;
  163.     iPtr->activeTracePtr = NULL;
  164.     iPtr->returnCode = TCL_OK;
  165.     iPtr->errorInfo = NULL;
  166.     iPtr->errorCode = NULL;
  167.     iPtr->numEvents = 0;
  168.     iPtr->events = NULL;
  169.     iPtr->curEvent = 0;
  170.     iPtr->curEventNum = 0;
  171.     iPtr->revPtr = NULL;
  172.     iPtr->historyFirst = NULL;
  173.     iPtr->revDisables = 1;
  174.     iPtr->evalFirst = iPtr->evalLast = NULL;
  175.     iPtr->appendResult = NULL;
  176.     iPtr->appendAvl = 0;
  177.     iPtr->appendUsed = 0;
  178.     for (i = 0; i < NUM_REGEXPS; i++) {
  179.     iPtr->patterns[i] = NULL;
  180.     iPtr->patLengths[i] = -1;
  181.     iPtr->regexps[i] = NULL;
  182.     }
  183.     strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT);
  184.     iPtr->pdPrec = DEFAULT_PD_PREC;
  185.     iPtr->cmdCount = 0;
  186.     iPtr->noEval = 0;
  187.     iPtr->evalFlags = 0;
  188.     iPtr->scriptFile = NULL;
  189.     iPtr->flags = 0;
  190.     iPtr->tracePtr = NULL;
  191.     iPtr->deleteCallbackPtr = NULL;
  192.     iPtr->resultSpace[0] = 0;
  193.  
  194.     /*
  195.      * Create the built-in commands.  Do it here, rather than calling
  196.      * Tcl_CreateCommand, because it's faster (there's no need to
  197.      * check for a pre-existing command by the same name).
  198.      */
  199.  
  200.     for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
  201.     int new;
  202.     Tcl_HashEntry *hPtr;
  203.  
  204.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable,
  205.         cmdInfoPtr->name, &new);
  206.     if (new) {
  207.         cmdPtr = (Command *) ckalloc(sizeof(Command));
  208.         cmdPtr->hPtr = hPtr;
  209.         cmdPtr->proc = cmdInfoPtr->proc;
  210.         cmdPtr->clientData = (ClientData) NULL;
  211.         cmdPtr->deleteProc = NULL;
  212.         cmdPtr->deleteData = (ClientData) NULL;
  213.         Tcl_SetHashValue(hPtr, cmdPtr);
  214.     }
  215.     }
  216.  
  217. #ifndef TCL_GENERIC_ONLY
  218.     TclSetupEnv((Tcl_Interp *) iPtr);
  219.  
  220.     /*
  221.      * The code below causes SIGPIPE (broken pipe) errors to
  222.      * be ignored.  This is needed so that Tcl processes don't
  223.      * die if they create child processes (e.g. using "exec" or
  224.      * "open") that terminate prematurely.  The signal handler
  225.      * is only set up when the first interpreter is created; 
  226.      * after this the application can override the handler with
  227.      * a different one of its own, if it wants.
  228.      */
  229.  
  230.     if (firstInterp) {
  231.     (void) signal(SIGPIPE, SIG_IGN);
  232.     firstInterp = 0;
  233.     }
  234. #endif
  235.  
  236.     /*
  237.      * Set up variables such as tcl_library and tcl_precision.
  238.      */
  239.  
  240.     libDir = getenv("TCL_LIBRARY");
  241.     if (libDir == NULL) {
  242.     libDir = TCL_LIBRARY;
  243.     }
  244.     Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_library", libDir, TCL_GLOBAL_ONLY);
  245.     Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL,
  246.         TCL_GLOBAL_ONLY);
  247.     Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION,
  248.         TCL_GLOBAL_ONLY);
  249.     Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
  250.         TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  251.         TclPrecTraceProc, (ClientData) NULL);
  252.     return (Tcl_Interp *) iPtr;
  253. }
  254.  
  255. /*
  256.  *----------------------------------------------------------------------
  257.  *
  258.  * Tcl_Init --
  259.  *
  260.  *    This procedure is typically invoked by Tcl_AppInit procedures
  261.  *    to perform additional initialization for a Tcl interpreter,
  262.  *    such as sourcing the "init.tcl" script.
  263.  *
  264.  * Results:
  265.  *    Returns a standard Tcl completion code and sets interp->result
  266.  *    if there is an error.
  267.  *
  268.  * Side effects:
  269.  *    Depends on what's in the init.tcl script.
  270.  *
  271.  *----------------------------------------------------------------------
  272.  */
  273.  
  274. int
  275. Tcl_Init(interp)
  276.     Tcl_Interp *interp;        /* Interpreter to initialize. */
  277. {
  278.     static char initCmd[] =
  279.     "if [file exists [info library]/init.tcl] {\n\
  280.         source [info library]/init.tcl\n\
  281.     } else {\n\
  282.         set msg \"can't find [info library]/init.tcl; perhaps you \"\n\
  283.         append msg \"need to\\ninstall Tcl or set your TCL_LIBRARY \"\n\
  284.         append msg \"environment variable?\"\n\
  285.         error $msg\n\
  286.     }";
  287.  
  288.     return Tcl_Eval(interp, initCmd);
  289. }
  290.  
  291. /*
  292.  *--------------------------------------------------------------
  293.  *
  294.  * Tcl_CallWhenDeleted --
  295.  *
  296.  *    Arrange for a procedure to be called before a given
  297.  *    interpreter is deleted.
  298.  *
  299.  * Results:
  300.  *    None.
  301.  *
  302.  * Side effects:
  303.  *    When Tcl_DeleteInterp is invoked to delete interp,
  304.  *    proc will be invoked.  See the manual entry for
  305.  *    details.
  306.  *
  307.  *--------------------------------------------------------------
  308.  */
  309.  
  310. void
  311. Tcl_CallWhenDeleted(interp, proc, clientData)
  312.     Tcl_Interp *interp;        /* Interpreter to watch. */
  313.     Tcl_InterpDeleteProc *proc;    /* Procedure to call when interpreter
  314.                  * is about to be deleted. */
  315.     ClientData clientData;    /* One-word value to pass to proc. */
  316. {
  317.     DeleteCallback *dcPtr, *prevPtr;
  318.     Interp *iPtr = (Interp *) interp;
  319.  
  320.     dcPtr = (DeleteCallback *) ckalloc(sizeof(DeleteCallback));
  321.     dcPtr->proc = proc;
  322.     dcPtr->clientData = clientData;
  323.     dcPtr->nextPtr = NULL;
  324.     if (iPtr->deleteCallbackPtr == NULL) {
  325.     iPtr->deleteCallbackPtr = dcPtr;
  326.     } else {
  327.     prevPtr = iPtr->deleteCallbackPtr;
  328.     while (prevPtr->nextPtr != NULL) {
  329.         prevPtr = prevPtr->nextPtr;
  330.     }
  331.     prevPtr->nextPtr = dcPtr;
  332.     }
  333. }
  334.  
  335. /*
  336.  *--------------------------------------------------------------
  337.  *
  338.  * Tcl_DontCallWhenDeleted --
  339.  *
  340.  *    Cancel the arrangement for a procedure to be called when
  341.  *    a given interpreter is deleted.
  342.  *
  343.  * Results:
  344.  *    None.
  345.  *
  346.  * Side effects:
  347.  *    If proc and clientData were previously registered as a
  348.  *    callback via Tcl_CallWhenDeleted, they are unregistered.
  349.  *    If they weren't previously registered then nothing
  350.  *    happens.
  351.  *
  352.  *--------------------------------------------------------------
  353.  */
  354.  
  355. void
  356. Tcl_DontCallWhenDeleted(interp, proc, clientData)
  357.     Tcl_Interp *interp;        /* Interpreter to watch. */
  358.     Tcl_InterpDeleteProc *proc;    /* Procedure to call when interpreter
  359.                  * is about to be deleted. */
  360.     ClientData clientData;    /* One-word value to pass to proc. */
  361. {
  362.     DeleteCallback *prevPtr, *dcPtr;
  363.     Interp *iPtr = (Interp *) interp;
  364.  
  365.     for (prevPtr = NULL, dcPtr = iPtr->deleteCallbackPtr;
  366.         dcPtr != NULL; prevPtr = dcPtr, dcPtr = dcPtr->nextPtr) {
  367.     if ((dcPtr->proc != proc) || (dcPtr->clientData != clientData)) {
  368.         continue;
  369.     }
  370.     if (prevPtr == NULL) {
  371.         iPtr->deleteCallbackPtr = dcPtr->nextPtr;
  372.     } else {
  373.         prevPtr->nextPtr = dcPtr->nextPtr;
  374.     }
  375.     ckfree((char *) dcPtr);
  376.     break;
  377.     }
  378. }
  379.  
  380. /*
  381.  *----------------------------------------------------------------------
  382.  *
  383.  * Tcl_DeleteInterp --
  384.  *
  385.  *    Delete an interpreter and free up all of the resources associated
  386.  *    with it.
  387.  *
  388.  * Results:
  389.  *    None.
  390.  *
  391.  * Side effects:
  392.  *    The interpreter is destroyed.  The caller should never again
  393.  *    use the interp token.
  394.  *
  395.  *----------------------------------------------------------------------
  396.  */
  397.  
  398. void
  399. Tcl_DeleteInterp(interp)
  400.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  401.                  * by a previous call to Tcl_CreateInterp). */
  402. {
  403.     Interp *iPtr = (Interp *) interp;
  404.     Tcl_HashEntry *hPtr;
  405.     Tcl_HashSearch search;
  406.     register Command *cmdPtr;
  407.     DeleteCallback *dcPtr;
  408.     int i;
  409.  
  410.     /*
  411.      * If the interpreter is in use, delay the deletion until later.
  412.      */
  413.  
  414.     iPtr->flags |= DELETED;
  415.     if (iPtr->numLevels != 0) {
  416.     return;
  417.     }
  418.  
  419.     /*
  420.      * Invoke deletion callbacks.
  421.      */
  422.  
  423.     while (iPtr->deleteCallbackPtr != NULL) {
  424.     dcPtr = iPtr->deleteCallbackPtr;
  425.     iPtr->deleteCallbackPtr = dcPtr->nextPtr;
  426.     (*dcPtr->proc)(dcPtr->clientData, interp);
  427.     ckfree((char *) dcPtr);
  428.     }
  429.  
  430.     /*
  431.      * Free up any remaining resources associated with the
  432.      * interpreter.
  433.      */
  434.  
  435.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  436.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  437.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  438.     if (cmdPtr->deleteProc != NULL) { 
  439.         (*cmdPtr->deleteProc)(cmdPtr->deleteData);
  440.     }
  441.     ckfree((char *) cmdPtr);
  442.     }
  443.     Tcl_DeleteHashTable(&iPtr->commandTable);
  444.     for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
  445.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  446.     ckfree((char *) Tcl_GetHashValue(hPtr));
  447.     }
  448.     Tcl_DeleteHashTable(&iPtr->mathFuncTable);
  449.     TclDeleteVars(iPtr, &iPtr->globalTable);
  450.  
  451.     /*
  452.      * Free up the result *after* deleting variables, since variable
  453.      * deletion could have transferred ownership of the result string
  454.      * to Tcl.
  455.      */
  456.  
  457.     Tcl_FreeResult(interp);
  458.     if (iPtr->errorInfo != NULL) {
  459.     ckfree(iPtr->errorInfo);
  460.     }
  461.     if (iPtr->errorCode != NULL) {
  462.     ckfree(iPtr->errorCode);
  463.     }
  464.     if (iPtr->events != NULL) {
  465.     int i;
  466.  
  467.     for (i = 0; i < iPtr->numEvents; i++) {
  468.         ckfree(iPtr->events[i].command);
  469.     }
  470.     ckfree((char *) iPtr->events);
  471.     }
  472.     while (iPtr->revPtr != NULL) {
  473.     HistoryRev *nextPtr = iPtr->revPtr->nextPtr;
  474.  
  475.     ckfree(iPtr->revPtr->newBytes);
  476.     ckfree((char *) iPtr->revPtr);
  477.     iPtr->revPtr = nextPtr;
  478.     }
  479.     if (iPtr->appendResult != NULL) {
  480.     ckfree(iPtr->appendResult);
  481.     }
  482.     for (i = 0; i < NUM_REGEXPS; i++) {
  483.     if (iPtr->patterns[i] == NULL) {
  484.         break;
  485.     }
  486.     ckfree(iPtr->patterns[i]);
  487.     ckfree((char *) iPtr->regexps[i]);
  488.     }
  489.     while (iPtr->tracePtr != NULL) {
  490.     Trace *nextPtr = iPtr->tracePtr->nextPtr;
  491.  
  492.     ckfree((char *) iPtr->tracePtr);
  493.     iPtr->tracePtr = nextPtr;
  494.     }
  495.     ckfree((char *) iPtr);
  496. }
  497.  
  498. /*
  499.  *----------------------------------------------------------------------
  500.  *
  501.  * Tcl_CreateCommand --
  502.  *
  503.  *    Define a new command in a command table.
  504.  *
  505.  * Results:
  506.  *    The return value is a token for the command, which can
  507.  *    be used in future calls to Tcl_NameOfCommand.
  508.  *
  509.  * Side effects:
  510.  *    If a command named cmdName already exists for interp, it is
  511.  *    deleted.  In the future, when cmdName is seen as the name of
  512.  *    a command by Tcl_Eval, proc will be called.  When the command
  513.  *    is deleted from the table, deleteProc will be called.  See the
  514.  *    manual entry for details on the calling sequence.
  515.  *
  516.  *----------------------------------------------------------------------
  517.  */
  518.  
  519. Tcl_Command
  520. Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
  521.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  522.                  * by a previous call to Tcl_CreateInterp). */
  523.     char *cmdName;        /* Name of command. */
  524.     Tcl_CmdProc *proc;        /* Command procedure to associate with
  525.                  * cmdName. */
  526.     ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
  527.     Tcl_CmdDeleteProc *deleteProc;
  528.                 /* If not NULL, gives a procedure to call when
  529.                  * this command is deleted. */
  530. {
  531.     Interp *iPtr = (Interp *) interp;
  532.     register Command *cmdPtr;
  533.     Tcl_HashEntry *hPtr;
  534.     int new;
  535.  
  536.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
  537.     if (!new) {
  538.     /*
  539.      * Command already exists:  delete the old one.
  540.      */
  541.  
  542.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  543.     if (cmdPtr->deleteProc != NULL) {
  544.         (*cmdPtr->deleteProc)(cmdPtr->deleteData);
  545.     }
  546.     } else {
  547.     cmdPtr = (Command *) ckalloc(sizeof(Command));
  548.     Tcl_SetHashValue(hPtr, cmdPtr);
  549.     }
  550.     cmdPtr->hPtr = hPtr;
  551.     cmdPtr->proc = proc;
  552.     cmdPtr->clientData = clientData;
  553.     cmdPtr->deleteProc = deleteProc;
  554.     cmdPtr->deleteData = clientData;
  555.     return (Tcl_Command) cmdPtr;
  556. }
  557.  
  558. /*
  559.  *----------------------------------------------------------------------
  560.  *
  561.  * Tcl_SetCommandInfo --
  562.  *
  563.  *    Modifies various information about a Tcl command.
  564.  *
  565.  * Results:
  566.  *    If cmdName exists in interp, then the information at *infoPtr
  567.  *    is stored with the command in place of the current information
  568.  *    and 1 is returned.  If the command doesn't exist then 0 is
  569.  *    returned.
  570.  *
  571.  * Side effects:
  572.  *    None.
  573.  *
  574.  *----------------------------------------------------------------------
  575.  */
  576.  
  577. int
  578. Tcl_SetCommandInfo(interp, cmdName, infoPtr)
  579.     Tcl_Interp *interp;            /* Interpreter in which to look
  580.                      * for command. */
  581.     char *cmdName;            /* Name of desired command. */
  582.     Tcl_CmdInfo *infoPtr;        /* Where to store information about
  583.                      * command. */
  584. {
  585.     Tcl_HashEntry *hPtr;
  586.     Command *cmdPtr;
  587.  
  588.     hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName);
  589.     if (hPtr == NULL) {
  590.     return 0;
  591.     }
  592.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  593.     cmdPtr->proc = infoPtr->proc;
  594.     cmdPtr->clientData = infoPtr->clientData;
  595.     cmdPtr->deleteProc = infoPtr->deleteProc;
  596.     cmdPtr->deleteData = infoPtr->deleteData;
  597.     return 1;
  598. }
  599.  
  600. /*
  601.  *----------------------------------------------------------------------
  602.  *
  603.  * Tcl_GetCommandInfo --
  604.  *
  605.  *    Returns various information about a Tcl command.
  606.  *
  607.  * Results:
  608.  *    If cmdName exists in interp, then *infoPtr is modified to
  609.  *    hold information about cmdName and 1 is returned.  If the
  610.  *    command doesn't exist then 0 is returned and *infoPtr isn't
  611.  *    modified.
  612.  *
  613.  * Side effects:
  614.  *    None.
  615.  *
  616.  *----------------------------------------------------------------------
  617.  */
  618.  
  619. int
  620. Tcl_GetCommandInfo(interp, cmdName, infoPtr)
  621.     Tcl_Interp *interp;            /* Interpreter in which to look
  622.                      * for command. */
  623.     char *cmdName;            /* Name of desired command. */
  624.     Tcl_CmdInfo *infoPtr;        /* Where to store information about
  625.                      * command. */
  626. {
  627.     Tcl_HashEntry *hPtr;
  628.     Command *cmdPtr;
  629.  
  630.     hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName);
  631.     if (hPtr == NULL) {
  632.     return 0;
  633.     }
  634.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  635.     infoPtr->proc = cmdPtr->proc;
  636.     infoPtr->clientData = cmdPtr->clientData;
  637.     infoPtr->deleteProc = cmdPtr->deleteProc;
  638.     infoPtr->deleteData = cmdPtr->deleteData;
  639.     return 1;
  640. }
  641.  
  642. /*
  643.  *----------------------------------------------------------------------
  644.  *
  645.  * Tcl_GetCommandName --
  646.  *
  647.  *    Given a token returned by Tcl_CreateCommand, this procedure
  648.  *    returns the current name of the command (which may have changed
  649.  *    due to renaming).
  650.  *
  651.  * Results:
  652.  *    The return value is the name of the given command.
  653.  *
  654.  * Side effects:
  655.  *    None.
  656.  *
  657.  *----------------------------------------------------------------------
  658.  */
  659.  
  660. char *
  661. Tcl_GetCommandName(interp, command)
  662.     Tcl_Interp *interp;        /* Interpreter containing the command. */
  663.     Tcl_Command command;    /* Token for the command, returned by a
  664.                  * previous call to Tcl_CreateCommand.
  665.                  * The command must not have been deleted. */
  666. {
  667.     Command *cmdPtr = (Command *) command;
  668.     Interp *iPtr = (Interp *) interp;
  669.  
  670.     return Tcl_GetHashKey(&iPtr->commandTable, cmdPtr->hPtr);
  671. }
  672.  
  673. /*
  674.  *----------------------------------------------------------------------
  675.  *
  676.  * Tcl_DeleteCommand --
  677.  *
  678.  *    Remove the given command from the given interpreter.
  679.  *
  680.  * Results:
  681.  *    0 is returned if the command was deleted successfully.
  682.  *    -1 is returned if there didn't exist a command by that
  683.  *    name.
  684.  *
  685.  * Side effects:
  686.  *    CmdName will no longer be recognized as a valid command for
  687.  *    interp.
  688.  *
  689.  *----------------------------------------------------------------------
  690.  */
  691.  
  692. int
  693. Tcl_DeleteCommand(interp, cmdName)
  694.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  695.                  * by a previous call to Tcl_CreateInterp). */
  696.     char *cmdName;        /* Name of command to remove. */
  697. {
  698.     Interp *iPtr = (Interp *) interp;
  699.     Tcl_HashEntry *hPtr;
  700.     Command *cmdPtr;
  701.  
  702.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
  703.     if (hPtr == NULL) {
  704.     return -1;
  705.     }
  706.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  707.     if (cmdPtr->deleteProc != NULL) {
  708.     (*cmdPtr->deleteProc)(cmdPtr->deleteData);
  709.     }
  710.     ckfree((char *) cmdPtr);
  711.     Tcl_DeleteHashEntry(hPtr);
  712.     return 0;
  713. }
  714.  
  715. /*
  716.  *-----------------------------------------------------------------
  717.  *
  718.  * Tcl_Eval --
  719.  *
  720.  *    Parse and execute a command in the Tcl language.
  721.  *
  722.  * Results:
  723.  *    The return value is one of the return codes defined in tcl.hd
  724.  *    (such as TCL_OK), and interp->result contains a string value
  725.  *    to supplement the return code.  The value of interp->result
  726.  *    will persist only until the next call to Tcl_Eval:  copy it or
  727.  *    lose it! *TermPtr is filled in with the character just after
  728.  *    the last one that was part of the command (usually a NULL
  729.  *    character or a closing bracket).
  730.  *
  731.  * Side effects:
  732.  *    Almost certainly;  depends on the command.
  733.  *
  734.  *-----------------------------------------------------------------
  735.  */
  736.  
  737. int
  738. Tcl_Eval(interp, cmd)
  739.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  740.                  * by a previous call to Tcl_CreateInterp). */
  741.     char *cmd;            /* Pointer to TCL command to interpret. */
  742. {
  743.     /*
  744.      * The storage immediately below is used to generate a copy
  745.      * of the command, after all argument substitutions.  Pv will
  746.      * contain the argv values passed to the command procedure.
  747.      */
  748.  
  749. #   define NUM_CHARS 200
  750.     char copyStorage[NUM_CHARS];
  751.     ParseValue pv;
  752.     char *oldBuffer;
  753.  
  754.     /*
  755.      * This procedure generates an (argv, argc) array for the command,
  756.      * It starts out with stack-allocated space but uses dynamically-
  757.      * allocated storage to increase it if needed.
  758.      */
  759.  
  760. #   define NUM_ARGS 10
  761.     char *(argStorage[NUM_ARGS]);
  762.     char **argv = argStorage;
  763.     int argc;
  764.     int argSize = NUM_ARGS;
  765.  
  766.     register char *src;            /* Points to current character
  767.                      * in cmd. */
  768.     char termChar;            /* Return when this character is found
  769.                      * (either ']' or '\0').  Zero means
  770.                      * that newlines terminate commands. */
  771.     int flags;                /* Interp->evalFlags value when the
  772.                      * procedure was called. */
  773.     int result;                /* Return value. */
  774.     register Interp *iPtr = (Interp *) interp;
  775.     Tcl_HashEntry *hPtr;
  776.     Command *cmdPtr;
  777.     char *termPtr;            /* Contains character just after the
  778.                      * last one in the command. */
  779.     char *cmdStart;            /* Points to first non-blank char. in
  780.                      * command (used in calling trace
  781.                      * procedures). */
  782.     char *ellipsis = "";        /* Used in setting errorInfo variable;
  783.                      * set to "..." to indicate that not
  784.                      * all of offending command is included
  785.                      * in errorInfo.  "" means that the
  786.                      * command is all there. */
  787.     register Trace *tracePtr;
  788.     int oldCount = iPtr->cmdCount;    /* Used to tell whether any commands
  789.                      * at all were executed. */
  790.  
  791.     /*
  792.      * Initialize the result to an empty string and clear out any
  793.      * error information.  This makes sure that we return an empty
  794.      * result if there are no commands in the command string.
  795.      */
  796.  
  797.     Tcl_FreeResult((Tcl_Interp *) iPtr);
  798.     iPtr->result = iPtr->resultSpace;
  799.     iPtr->resultSpace[0] = 0;
  800.     result = TCL_OK;
  801.  
  802.     /*
  803.      * Initialize the area in which command copies will be assembled.
  804.      */
  805.  
  806.     pv.buffer = copyStorage;
  807.     pv.end = copyStorage + NUM_CHARS - 1;
  808.     pv.expandProc = TclExpandParseValue;
  809.     pv.clientData = (ClientData) NULL;
  810.  
  811.     src = cmd;
  812.     flags = iPtr->evalFlags;
  813.     iPtr->evalFlags = 0;
  814.     if (flags & TCL_BRACKET_TERM) {
  815.     termChar = ']';
  816.     } else {
  817.     termChar = 0;
  818.     }
  819.     termPtr = src;
  820.     cmdStart = src;
  821.  
  822.     /*
  823.      * Check depth of nested calls to Tcl_Eval:  if this gets too large,
  824.      * it's probably because of an infinite loop somewhere.
  825.      */
  826.  
  827.     iPtr->numLevels++;
  828.     if (iPtr->numLevels > iPtr->maxNestingDepth) {
  829.     iPtr->numLevels--;
  830.     iPtr->result =  "too many nested calls to Tcl_Eval (infinite loop?)";
  831.     iPtr->termPtr = termPtr;
  832.     return TCL_ERROR;
  833.     }
  834.  
  835.     /*
  836.      * There can be many sub-commands (separated by semi-colons or
  837.      * newlines) in one command string.  This outer loop iterates over
  838.      * individual commands.
  839.      */
  840.  
  841.     while (*src != termChar) {
  842.     iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET);
  843.  
  844.     /*
  845.      * Skim off leading white space and semi-colons, and skip
  846.      * comments.
  847.      */
  848.  
  849.     while (1) {
  850.         register char c = *src;
  851.  
  852.         if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) {
  853.         break;
  854.         }
  855.         src += 1;
  856.     }
  857.     if (*src == '#') {
  858.         for (src++; *src != 0; src++) {
  859.         if ((*src == '\n') && (src[-1] != '\\')) {
  860.             src++;
  861.             termPtr = src;
  862.             break;
  863.         }
  864.         }
  865.         continue;
  866.     }
  867.     cmdStart = src;
  868.  
  869.     /*
  870.      * Parse the words of the command, generating the argc and
  871.      * argv for the command procedure.  May have to call
  872.      * TclParseWords several times, expanding the argv array
  873.      * between calls.
  874.      */
  875.  
  876.     pv.next = oldBuffer = pv.buffer;
  877.     argc = 0;
  878.     while (1) {
  879.         int newArgs, maxArgs;
  880.         char **newArgv;
  881.         int i;
  882.  
  883.         /*
  884.          * Note:  the "- 2" below guarantees that we won't use the
  885.          * last two argv slots here.  One is for a NULL pointer to
  886.          * mark the end of the list, and the other is to leave room
  887.          * for inserting the command name "unknown" as the first
  888.          * argument (see below).
  889.          */
  890.  
  891.         maxArgs = argSize - argc - 2;
  892.         result = TclParseWords((Tcl_Interp *) iPtr, src, flags,
  893.             maxArgs, &termPtr, &newArgs, &argv[argc], &pv);
  894.         src = termPtr;
  895.         if (result != TCL_OK) {
  896.         ellipsis = "...";
  897.         goto done;
  898.         }
  899.  
  900.         /*
  901.          * Careful!  Buffer space may have gotten reallocated while
  902.          * parsing words.  If this happened, be sure to update all
  903.          * of the older argv pointers to refer to the new space.
  904.          */
  905.  
  906.         if (oldBuffer != pv.buffer) {
  907.         int i;
  908.  
  909.         for (i = 0; i < argc; i++) {
  910.             argv[i] = pv.buffer + (argv[i] - oldBuffer);
  911.         }
  912.         oldBuffer = pv.buffer;
  913.         }
  914.         argc += newArgs;
  915.         if (newArgs < maxArgs) {
  916.         argv[argc] = (char *) NULL;
  917.         break;
  918.         }
  919.  
  920.         /*
  921.          * Args didn't all fit in the current array.  Make it bigger.
  922.          */
  923.  
  924.         argSize *= 2;
  925.         newArgv = (char **)
  926.             ckalloc((unsigned) argSize * sizeof(char *));
  927.         for (i = 0; i < argc; i++) {
  928.         newArgv[i] = argv[i];
  929.         }
  930.         if (argv != argStorage) {
  931.         ckfree((char *) argv);
  932.         }
  933.         argv = newArgv;
  934.     }
  935.  
  936.     /*
  937.      * If this is an empty command (or if we're just parsing
  938.      * commands without evaluating them), then just skip to the
  939.      * next command.
  940.      */
  941.  
  942.     if ((argc == 0) || iPtr->noEval) {
  943.         continue;
  944.     }
  945.     argv[argc] = NULL;
  946.  
  947.     /*
  948.      * Save information for the history module, if needed.
  949.      */
  950.  
  951.     if (flags & TCL_RECORD_BOUNDS) {
  952.         iPtr->evalFirst = cmdStart;
  953.         iPtr->evalLast = src-1;
  954.     }
  955.  
  956.     /*
  957.      * Find the procedure to execute this command.  If there isn't
  958.      * one, then see if there is a command "unknown".  If so,
  959.      * invoke it instead, passing it the words of the original
  960.      * command as arguments.
  961.      */
  962.  
  963.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]);
  964.     if (hPtr == NULL) {
  965.         int i;
  966.  
  967.         hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown");
  968.         if (hPtr == NULL) {
  969.         Tcl_ResetResult(interp);
  970.         Tcl_AppendResult(interp, "invalid command name \"",
  971.             argv[0], "\"", (char *) NULL);
  972.         result = TCL_ERROR;
  973.         goto done;
  974.         }
  975.         for (i = argc; i >= 0; i--) {
  976.         argv[i+1] = argv[i];
  977.         }
  978.         argv[0] = "unknown";
  979.         argc++;
  980.     }
  981.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  982.  
  983.     /*
  984.      * Call trace procedures, if any.
  985.      */
  986.  
  987.     for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
  988.         tracePtr = tracePtr->nextPtr) {
  989.         char saved;
  990.  
  991.         if (tracePtr->level < iPtr->numLevels) {
  992.         continue;
  993.         }
  994.         saved = *src;
  995.         *src = 0;
  996.         (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
  997.             cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
  998.         *src = saved;
  999.     }
  1000.  
  1001.     /*
  1002.      * At long last, invoke the command procedure.  Reset the
  1003.      * result to its default empty value first (it could have
  1004.      * gotten changed by earlier commands in the same command
  1005.      * string).
  1006.      */
  1007.  
  1008.     iPtr->cmdCount++;
  1009.     Tcl_FreeResult(iPtr);
  1010.     iPtr->result = iPtr->resultSpace;
  1011.     iPtr->resultSpace[0] = 0;
  1012.     result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);
  1013.     if (tcl_AsyncReady) {
  1014.         result = Tcl_AsyncInvoke(interp, result);
  1015.     }
  1016.     if (result != TCL_OK) {
  1017.         break;
  1018.     }
  1019.     }
  1020.  
  1021.     done:
  1022.  
  1023.     /*
  1024.      * If no commands at all were executed, check for asynchronous
  1025.      * handlers so that they at least get one change to execute.
  1026.      * This is needed to handle event loops written in Tcl with
  1027.      * empty bodies (I'm not sure that loops like this are a good
  1028.      * idea, * but...).
  1029.      */
  1030.  
  1031.     if ((oldCount == iPtr->cmdCount) && (tcl_AsyncReady)) {
  1032.     result = Tcl_AsyncInvoke(interp, result);
  1033.     }
  1034.  
  1035.     /*
  1036.      * Free up any extra resources that were allocated.
  1037.      */
  1038.  
  1039.     if (pv.buffer != copyStorage) {
  1040.     ckfree((char *) pv.buffer);
  1041.     }
  1042.     if (argv != argStorage) {
  1043.     ckfree((char *) argv);
  1044.     }
  1045.     iPtr->numLevels--;
  1046.     if (iPtr->numLevels == 0) {
  1047.     if (result == TCL_RETURN) {
  1048.         result = TclUpdateReturnInfo(iPtr);
  1049.     }
  1050.     if ((result != TCL_OK) && (result != TCL_ERROR)
  1051.         && !(flags & TCL_ALLOW_EXCEPTIONS)) {
  1052.         Tcl_ResetResult(interp);
  1053.         if (result == TCL_BREAK) {
  1054.         iPtr->result = "invoked \"break\" outside of a loop";
  1055.         } else if (result == TCL_CONTINUE) {
  1056.         iPtr->result = "invoked \"continue\" outside of a loop";
  1057.         } else {
  1058.         iPtr->result = iPtr->resultSpace;
  1059.         sprintf(iPtr->resultSpace, "command returned bad code: %d",
  1060.             result);
  1061.         }
  1062.         result = TCL_ERROR;
  1063.     }
  1064.     if (iPtr->flags & DELETED) {
  1065.         /*
  1066.          * Someone tried to delete the interpreter, but it couldn't
  1067.          * actually be deleted because commands were in the middle of
  1068.          * being evaluated.  Delete the interpreter now.  Also, return
  1069.          * immediately:  we can't execute the remaining code in the
  1070.          * procedure because it accesses fields of the dead interpreter.
  1071.          */
  1072.  
  1073.         Tcl_DeleteInterp(interp);
  1074.         return result;
  1075.     }
  1076.     }
  1077.  
  1078.     /*
  1079.      * If an error occurred, record information about what was being
  1080.      * executed when the error occurred.
  1081.      */
  1082.  
  1083.     if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
  1084.     int numChars;
  1085.     register char *p;
  1086.  
  1087.     /*
  1088.      * Compute the line number where the error occurred.
  1089.      */
  1090.  
  1091.     iPtr->errorLine = 1;
  1092.     for (p = cmd; p != cmdStart; p++) {
  1093.         if (*p == '\n') {
  1094.         iPtr->errorLine++;
  1095.         }
  1096.     }
  1097.     for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) {
  1098.         if (*p == '\n') {
  1099.         iPtr->errorLine++;
  1100.         }
  1101.     }
  1102.  
  1103.     /*
  1104.      * Figure out how much of the command to print in the error
  1105.      * message (up to a certain number of characters, or up to
  1106.      * the first new-line).
  1107.      */
  1108.  
  1109.     numChars = src - cmdStart;
  1110.     if (numChars > (NUM_CHARS-50)) {
  1111.         numChars = NUM_CHARS-50;
  1112.         ellipsis = " ...";
  1113.     }
  1114.  
  1115.     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
  1116.         sprintf(copyStorage, "\n    while executing\n\"%.*s%s\"",
  1117.             numChars, cmdStart, ellipsis);
  1118.     } else {
  1119.         sprintf(copyStorage, "\n    invoked from within\n\"%.*s%s\"",
  1120.             numChars, cmdStart, ellipsis);
  1121.     }
  1122.     Tcl_AddErrorInfo(interp, copyStorage);
  1123.     iPtr->flags &= ~ERR_ALREADY_LOGGED;
  1124.     } else {
  1125.     iPtr->flags &= ~ERR_ALREADY_LOGGED;
  1126.     }
  1127.     iPtr->termPtr = termPtr;
  1128.     return result;
  1129. }
  1130.  
  1131. /*
  1132.  *----------------------------------------------------------------------
  1133.  *
  1134.  * Tcl_CreateTrace --
  1135.  *
  1136.  *    Arrange for a procedure to be called to trace command execution.
  1137.  *
  1138.  * Results:
  1139.  *    The return value is a token for the trace, which may be passed
  1140.  *    to Tcl_DeleteTrace to eliminate the trace.
  1141.  *
  1142.  * Side effects:
  1143.  *    From now on, proc will be called just before a command procedure
  1144.  *    is called to execute a Tcl command.  Calls to proc will have the
  1145.  *    following form:
  1146.  *
  1147.  *    void
  1148.  *    proc(clientData, interp, level, command, cmdProc, cmdClientData,
  1149.  *        argc, argv)
  1150.  *        ClientData clientData;
  1151.  *        Tcl_Interp *interp;
  1152.  *        int level;
  1153.  *        char *command;
  1154.  *        int (*cmdProc)();
  1155.  *        ClientData cmdClientData;
  1156.  *        int argc;
  1157.  *        char **argv;
  1158.  *    {
  1159.  *    }
  1160.  *
  1161.  *    The clientData and interp arguments to proc will be the same
  1162.  *    as the corresponding arguments to this procedure.  Level gives
  1163.  *    the nesting level of command interpretation for this interpreter
  1164.  *    (0 corresponds to top level).  Command gives the ASCII text of
  1165.  *    the raw command, cmdProc and cmdClientData give the procedure that
  1166.  *    will be called to process the command and the ClientData value it
  1167.  *    will receive, and argc and argv give the arguments to the
  1168.  *    command, after any argument parsing and substitution.  Proc
  1169.  *    does not return a value.
  1170.  *
  1171.  *----------------------------------------------------------------------
  1172.  */
  1173.  
  1174. Tcl_Trace
  1175. Tcl_CreateTrace(interp, level, proc, clientData)
  1176.     Tcl_Interp *interp;        /* Interpreter in which to create the trace. */
  1177.     int level;            /* Only call proc for commands at nesting level
  1178.                  * <= level (1 => top level). */
  1179.     Tcl_CmdTraceProc *proc;    /* Procedure to call before executing each
  1180.                  * command. */
  1181.     ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
  1182. {
  1183.     register Trace *tracePtr;
  1184.     register Interp *iPtr = (Interp *) interp;
  1185.  
  1186.     tracePtr = (Trace *) ckalloc(sizeof(Trace));
  1187.     tracePtr->level = level;
  1188.     tracePtr->proc = proc;
  1189.     tracePtr->clientData = clientData;
  1190.     tracePtr->nextPtr = iPtr->tracePtr;
  1191.     iPtr->tracePtr = tracePtr;
  1192.  
  1193.     return (Tcl_Trace) tracePtr;
  1194. }
  1195.  
  1196. /*
  1197.  *----------------------------------------------------------------------
  1198.  *
  1199.  * Tcl_DeleteTrace --
  1200.  *
  1201.  *    Remove a trace.
  1202.  *
  1203.  * Results:
  1204.  *    None.
  1205.  *
  1206.  * Side effects:
  1207.  *    From now on there will be no more calls to the procedure given
  1208.  *    in trace.
  1209.  *
  1210.  *----------------------------------------------------------------------
  1211.  */
  1212.  
  1213. void
  1214. Tcl_DeleteTrace(interp, trace)
  1215.     Tcl_Interp *interp;        /* Interpreter that contains trace. */
  1216.     Tcl_Trace trace;        /* Token for trace (returned previously by
  1217.                  * Tcl_CreateTrace). */
  1218. {
  1219.     register Interp *iPtr = (Interp *) interp;
  1220.     register Trace *tracePtr = (Trace *) trace;
  1221.     register Trace *tracePtr2;
  1222.  
  1223.     if (iPtr->tracePtr == tracePtr) {
  1224.     iPtr->tracePtr = tracePtr->nextPtr;
  1225.     ckfree((char *) tracePtr);
  1226.     } else {
  1227.     for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
  1228.         tracePtr2 = tracePtr2->nextPtr) {
  1229.         if (tracePtr2->nextPtr == tracePtr) {
  1230.         tracePtr2->nextPtr = tracePtr->nextPtr;
  1231.         ckfree((char *) tracePtr);
  1232.         return;
  1233.         }
  1234.     }
  1235.     }
  1236. }
  1237.  
  1238. /*
  1239.  *----------------------------------------------------------------------
  1240.  *
  1241.  * Tcl_AddErrorInfo --
  1242.  *
  1243.  *    Add information to a message being accumulated that describes
  1244.  *    the current error.
  1245.  *
  1246.  * Results:
  1247.  *    None.
  1248.  *
  1249.  * Side effects:
  1250.  *    The contents of message are added to the "errorInfo" variable.
  1251.  *    If Tcl_Eval has been called since the current value of errorInfo
  1252.  *    was set, errorInfo is cleared before adding the new message.
  1253.  *
  1254.  *----------------------------------------------------------------------
  1255.  */
  1256.  
  1257. void
  1258. Tcl_AddErrorInfo(interp, message)
  1259.     Tcl_Interp *interp;        /* Interpreter to which error information
  1260.                  * pertains. */
  1261.     char *message;        /* Message to record. */
  1262. {
  1263.     register Interp *iPtr = (Interp *) interp;
  1264.  
  1265.     /*
  1266.      * If an error is already being logged, then the new errorInfo
  1267.      * is the concatenation of the old info and the new message.
  1268.      * If this is the first piece of info for the error, then the
  1269.      * new errorInfo is the concatenation of the message in
  1270.      * interp->result and the new message.
  1271.      */
  1272.  
  1273.     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
  1274.     Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
  1275.         TCL_GLOBAL_ONLY);
  1276.     iPtr->flags |= ERR_IN_PROGRESS;
  1277.  
  1278.     /*
  1279.      * If the errorCode variable wasn't set by the code that generated
  1280.      * the error, set it to "NONE".
  1281.      */
  1282.  
  1283.     if (!(iPtr->flags & ERROR_CODE_SET)) {
  1284.         (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
  1285.             TCL_GLOBAL_ONLY);
  1286.     }
  1287.     }
  1288.     Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message,
  1289.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
  1290. }
  1291.  
  1292. /*
  1293.  *----------------------------------------------------------------------
  1294.  *
  1295.  * Tcl_VarEval --
  1296.  *
  1297.  *    Given a variable number of string arguments, concatenate them
  1298.  *    all together and execute the result as a Tcl command.
  1299.  *
  1300.  * Results:
  1301.  *    A standard Tcl return result.  An error message or other
  1302.  *    result may be left in interp->result.
  1303.  *
  1304.  * Side effects:
  1305.  *    Depends on what was done by the command.
  1306.  *
  1307.  *----------------------------------------------------------------------
  1308.  */
  1309.     /* VARARGS2 */ /* ARGSUSED */
  1310. int
  1311. #ifndef lint
  1312. Tcl_VarEval(va_alist)
  1313. #else
  1314. Tcl_VarEval(iPtr, p, va_alist)
  1315.     Tcl_Interp *iPtr;        /* Interpreter in which to execute command. */
  1316.     char *p;            /* One or more strings to concatenate,
  1317.                  * terminated with a NULL string. */
  1318. #endif
  1319.     va_dcl
  1320. {
  1321.     va_list argList;
  1322.     Tcl_DString buf;
  1323.     char *string;
  1324.     Tcl_Interp *interp;
  1325.     int result;
  1326.  
  1327.     /*
  1328.      * Copy the strings one after the other into a single larger
  1329.      * string.  Use stack-allocated space for small commands, but if
  1330.      * the command gets too large than call ckalloc to create the
  1331.      * space.
  1332.      */
  1333.  
  1334.     va_start(argList);
  1335.     interp = va_arg(argList, Tcl_Interp *);
  1336.     Tcl_DStringInit(&buf);
  1337.     while (1) {
  1338.     string = va_arg(argList, char *);
  1339.     if (string == NULL) {
  1340.         break;
  1341.     }
  1342.     Tcl_DStringAppend(&buf, string, -1);
  1343.     }
  1344.     va_end(argList);
  1345.  
  1346.     result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
  1347.     Tcl_DStringFree(&buf);
  1348.     return result;
  1349. }
  1350.  
  1351. /*
  1352.  *----------------------------------------------------------------------
  1353.  *
  1354.  * Tcl_GlobalEval --
  1355.  *
  1356.  *    Evaluate a command at global level in an interpreter.
  1357.  *
  1358.  * Results:
  1359.  *    A standard Tcl result is returned, and interp->result is
  1360.  *    modified accordingly.
  1361.  *
  1362.  * Side effects:
  1363.  *    The command string is executed in interp, and the execution
  1364.  *    is carried out in the variable context of global level (no
  1365.  *    procedures active), just as if an "uplevel #0" command were
  1366.  *    being executed.
  1367.  *
  1368.  *----------------------------------------------------------------------
  1369.  */
  1370.  
  1371. int
  1372. Tcl_GlobalEval(interp, command)
  1373.     Tcl_Interp *interp;        /* Interpreter in which to evaluate command. */
  1374.     char *command;        /* Command to evaluate. */
  1375. {
  1376.     register Interp *iPtr = (Interp *) interp;
  1377.     int result;
  1378.     CallFrame *savedVarFramePtr;
  1379.  
  1380.     savedVarFramePtr = iPtr->varFramePtr;
  1381.     iPtr->varFramePtr = NULL;
  1382.     result = Tcl_Eval(interp, command);
  1383.     iPtr->varFramePtr = savedVarFramePtr;
  1384.     return result;
  1385. }
  1386.  
  1387. /*
  1388.  *----------------------------------------------------------------------
  1389.  *
  1390.  * Tcl_SetRecursionLimit --
  1391.  *
  1392.  *    Set the maximum number of recursive calls that may be active
  1393.  *    for an interpreter at once.
  1394.  *
  1395.  * Results:
  1396.  *    The return value is the old limit on nesting for interp.
  1397.  *
  1398.  * Side effects:
  1399.  *    None.
  1400.  *
  1401.  *----------------------------------------------------------------------
  1402.  */
  1403.  
  1404. int
  1405. Tcl_SetRecursionLimit(interp, depth)
  1406.     Tcl_Interp *interp;            /* Interpreter whose nesting limit
  1407.                      * is to be set. */
  1408.     int depth;                /* New value for maximimum depth. */
  1409. {
  1410.     Interp *iPtr = (Interp *) interp;
  1411.     int old;
  1412.  
  1413.     old = iPtr->maxNestingDepth;
  1414.     if (depth > 0) {
  1415.     iPtr->maxNestingDepth = depth;
  1416.     }
  1417.     return old;
  1418. }
  1419.  
  1420. /*
  1421.  *----------------------------------------------------------------------
  1422.  *
  1423.  * Tcl_AllowExceptions --
  1424.  *
  1425.  *    Sets a flag in an interpreter so that exceptions can occur
  1426.  *    in the next call to Tcl_Eval without them being turned into
  1427.  *    errors.
  1428.  *
  1429.  * Results:
  1430.  *    None.
  1431.  *
  1432.  * Side effects:
  1433.  *    The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
  1434.  *    evalFlags structure.  See the reference documentation for
  1435.  *    more details.
  1436.  *
  1437.  *----------------------------------------------------------------------
  1438.  */
  1439.  
  1440. void
  1441. Tcl_AllowExceptions(interp)
  1442.     Tcl_Interp *interp;        /* Interpreter in which to set flag. */
  1443. {
  1444.     Interp *iPtr = (Interp *) interp;
  1445.  
  1446.     iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
  1447. }
  1448.