home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / tcl / os2 / tclBasic.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-08-07  |  49.1 KB  |  1,827 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-1996 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.  * SCCS: @(#) tclBasic.c 1.210 96/03/25 17:17:54
  15.  */
  16.  
  17. #include "tclInt.h"
  18. #ifndef TCL_GENERIC_ONLY
  19. #   include "tclPort.h"
  20. #endif
  21. #include "patchlevel.h"
  22.  
  23. /*
  24.  * Static procedures in this file:
  25.  */
  26.  
  27. static void        DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
  28.  
  29. /*
  30.  * The following structure defines all of the commands in the Tcl core,
  31.  * and the C procedures that execute them.
  32.  */
  33.  
  34. typedef struct {
  35.     char *name;            /* Name of command. */
  36.     Tcl_CmdProc *proc;        /* Procedure that executes command. */
  37. } CmdInfo;
  38.  
  39. /*
  40.  * Built-in commands, and the procedures associated with them:
  41.  */
  42.  
  43. static CmdInfo builtInCmds[] = {
  44.     /*
  45.      * Commands in the generic core:
  46.      */
  47.  
  48.     {"append",        Tcl_AppendCmd},
  49.     {"array",        Tcl_ArrayCmd},
  50.     {"break",        Tcl_BreakCmd},
  51.     {"case",        Tcl_CaseCmd},
  52.     {"catch",        Tcl_CatchCmd},
  53.     {"clock",        Tcl_ClockCmd},
  54.     {"concat",        Tcl_ConcatCmd},
  55.     {"continue",    Tcl_ContinueCmd},
  56.     {"error",        Tcl_ErrorCmd},
  57.     {"eval",        Tcl_EvalCmd},
  58.     {"exit",        Tcl_ExitCmd},
  59.     {"expr",        Tcl_ExprCmd},
  60.     {"fileevent",    Tcl_FileEventCmd},
  61.     {"for",        Tcl_ForCmd},
  62.     {"foreach",        Tcl_ForeachCmd},
  63.     {"format",        Tcl_FormatCmd},
  64.     {"global",        Tcl_GlobalCmd},
  65.     {"history",        Tcl_HistoryCmd},
  66.     {"if",        Tcl_IfCmd},
  67.     {"incr",        Tcl_IncrCmd},
  68.     {"info",        Tcl_InfoCmd},
  69.     {"interp",        Tcl_InterpCmd},
  70.     {"join",        Tcl_JoinCmd},
  71.     {"lappend",        Tcl_LappendCmd},
  72.     {"lindex",        Tcl_LindexCmd},
  73.     {"linsert",        Tcl_LinsertCmd},
  74.     {"list",        Tcl_ListCmd},
  75.     {"llength",        Tcl_LlengthCmd},
  76.     {"load",        Tcl_LoadCmd},
  77.     {"lrange",        Tcl_LrangeCmd},
  78.     {"lreplace",    Tcl_LreplaceCmd},
  79.     {"lsearch",        Tcl_LsearchCmd},
  80.     {"lsort",        Tcl_LsortCmd},
  81.     {"package",        Tcl_PackageCmd},
  82.     {"proc",        Tcl_ProcCmd},
  83.     {"regexp",        Tcl_RegexpCmd},
  84.     {"regsub",        Tcl_RegsubCmd},
  85.     {"rename",        Tcl_RenameCmd},
  86.     {"return",        Tcl_ReturnCmd},
  87.     {"scan",        Tcl_ScanCmd},
  88.     {"set",        Tcl_SetCmd},
  89.     {"split",        Tcl_SplitCmd},
  90.     {"string",        Tcl_StringCmd},
  91.     {"subst",        Tcl_SubstCmd},
  92.     {"switch",        Tcl_SwitchCmd},
  93.     {"trace",        Tcl_TraceCmd},
  94.     {"unset",        Tcl_UnsetCmd},
  95.     {"uplevel",        Tcl_UplevelCmd},
  96.     {"upvar",        Tcl_UpvarCmd},
  97.     {"while",        Tcl_WhileCmd},
  98.  
  99.     /*
  100.      * Commands in the UNIX core:
  101.      */
  102.  
  103. #ifndef TCL_GENERIC_ONLY
  104.     {"after",        Tcl_AfterCmd},
  105.     {"cd",        Tcl_CdCmd},
  106.     {"close",        Tcl_CloseCmd},
  107.     {"eof",        Tcl_EofCmd},
  108.     {"fblocked",    Tcl_FblockedCmd},
  109.     {"fconfigure",    Tcl_FconfigureCmd},
  110.     {"file",        Tcl_FileCmd},
  111.     {"flush",        Tcl_FlushCmd},
  112.     {"gets",        Tcl_GetsCmd},
  113.     {"glob",        Tcl_GlobCmd},
  114.     {"open",        Tcl_OpenCmd},
  115.     {"pid",        Tcl_PidCmd},
  116.     {"puts",        Tcl_PutsCmd},
  117.     {"pwd",        Tcl_PwdCmd},
  118.     {"read",        Tcl_ReadCmd},
  119.     {"seek",        Tcl_SeekCmd},
  120.     {"socket",        Tcl_SocketCmd},
  121.     {"tell",        Tcl_TellCmd},
  122.     {"time",        Tcl_TimeCmd},
  123.     {"update",        Tcl_UpdateCmd},
  124.     {"vwait",        Tcl_VwaitCmd},
  125.     {"unsupported0",    TclUnsupported0Cmd},
  126.     
  127. #ifndef MAC_TCL
  128.     {"exec",        Tcl_ExecCmd},
  129.     {"source",        Tcl_SourceCmd},
  130. #endif
  131.     
  132. #ifdef MAC_TCL
  133.     {"beep",        Tcl_MacBeepCmd},
  134.     {"cp",        Tcl_CpCmd},
  135.     {"echo",        Tcl_EchoCmd},
  136.     {"ls",        Tcl_LsCmd},
  137.     {"mkdir",        Tcl_MkdirCmd},
  138.     {"mv",        Tcl_MvCmd},
  139.     {"rm",        Tcl_RmCmd},
  140.     {"rmdir",        Tcl_RmdirCmd},
  141.     {"source",        Tcl_MacSourceCmd},
  142. #endif /* MAC_TCL */
  143.     
  144. #endif /* TCL_GENERIC_ONLY */
  145.     {NULL,        (Tcl_CmdProc *) NULL}
  146. };
  147.  
  148. /*
  149.  *----------------------------------------------------------------------
  150.  *
  151.  * Tcl_CreateInterp --
  152.  *
  153.  *    Create a new TCL command interpreter.
  154.  *
  155.  * Results:
  156.  *    The return value is a token for the interpreter, which may be
  157.  *    used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
  158.  *    Tcl_DeleteInterp.
  159.  *
  160.  * Side effects:
  161.  *    The command interpreter is initialized with an empty variable
  162.  *    table and the built-in commands.
  163.  *
  164.  *----------------------------------------------------------------------
  165.  */
  166.  
  167. Tcl_Interp *
  168. Tcl_CreateInterp()
  169. {
  170.     register Interp *iPtr;
  171.     register Command *cmdPtr;
  172.     register CmdInfo *cmdInfoPtr;
  173.     Tcl_Channel chan;
  174.     int i;
  175.  
  176.     iPtr = (Interp *) ckalloc(sizeof(Interp));
  177.     iPtr->result = iPtr->resultSpace;
  178.     iPtr->freeProc = 0;
  179.     iPtr->errorLine = 0;
  180.     Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS);
  181.     Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
  182.     Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS);
  183.     iPtr->numLevels = 0;
  184.     iPtr->maxNestingDepth = 1000;
  185.     iPtr->framePtr = NULL;
  186.     iPtr->varFramePtr = NULL;
  187.     iPtr->activeTracePtr = NULL;
  188.     iPtr->returnCode = TCL_OK;
  189.     iPtr->errorInfo = NULL;
  190.     iPtr->errorCode = NULL;
  191.     iPtr->numEvents = 0;
  192.     iPtr->events = NULL;
  193.     iPtr->curEvent = 0;
  194.     iPtr->curEventNum = 0;
  195.     iPtr->revPtr = NULL;
  196.     iPtr->historyFirst = NULL;
  197.     iPtr->revDisables = 1;
  198.     iPtr->evalFirst = iPtr->evalLast = NULL;
  199.     iPtr->appendResult = NULL;
  200.     iPtr->appendAvl = 0;
  201.     iPtr->appendUsed = 0;
  202.     for (i = 0; i < NUM_REGEXPS; i++) {
  203.     iPtr->patterns[i] = NULL;
  204.     iPtr->patLengths[i] = -1;
  205.     iPtr->regexps[i] = NULL;
  206.     }
  207.     Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
  208.     iPtr->packageUnknown = NULL;
  209.     strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT);
  210.     iPtr->pdPrec = DEFAULT_PD_PREC;
  211.     iPtr->cmdCount = 0;
  212.     iPtr->noEval = 0;
  213.     iPtr->evalFlags = 0;
  214.     iPtr->scriptFile = NULL;
  215.     iPtr->flags = 0;
  216.     iPtr->tracePtr = NULL;
  217.     iPtr->assocData = (Tcl_HashTable *) NULL;
  218.     iPtr->resultSpace[0] = 0;
  219.  
  220.     /*
  221.      * Create the built-in commands.  Do it here, rather than calling
  222.      * Tcl_CreateCommand, because it's faster (there's no need to
  223.      * check for a pre-existing command by the same name).
  224.      */
  225.  
  226.     for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
  227.     int new;
  228.     Tcl_HashEntry *hPtr;
  229.  
  230.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable,
  231.         cmdInfoPtr->name, &new);
  232.     if (new) {
  233.         cmdPtr = (Command *) ckalloc(sizeof(Command));
  234.         cmdPtr->hPtr = hPtr;
  235.         cmdPtr->proc = cmdInfoPtr->proc;
  236.         cmdPtr->clientData = (ClientData) NULL;
  237.         cmdPtr->deleteProc = NULL;
  238.         cmdPtr->deleteData = (ClientData) NULL;
  239.         cmdPtr->deleted = 0;
  240.         Tcl_SetHashValue(hPtr, cmdPtr);
  241.     }
  242.     }
  243.  
  244. #ifndef TCL_GENERIC_ONLY
  245.     TclSetupEnv((Tcl_Interp *) iPtr);
  246. #endif
  247.  
  248.     /*
  249.      * Do Safe-Tcl init stuff
  250.      */
  251.  
  252.     (void) TclInterpInit((Tcl_Interp *)iPtr);
  253.  
  254.     /*
  255.      * Set up variables such as tcl_library and tcl_precision.
  256.      */
  257.  
  258.     TclPlatformInit((Tcl_Interp *)iPtr);
  259.     Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL,
  260.         TCL_GLOBAL_ONLY);
  261.     Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION,
  262.         TCL_GLOBAL_ONLY);
  263.     Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
  264.         TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  265.         TclPrecTraceProc, (ClientData) NULL);
  266.  
  267.     /*
  268.      * Register Tcl's version number.
  269.      */
  270.  
  271.     Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION);
  272.  
  273.     /*
  274.      * Add the standard channels.
  275.      */
  276.  
  277.     chan = Tcl_GetStdChannel(TCL_STDIN);
  278.     if (chan != (Tcl_Channel) NULL) {
  279.         Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan);
  280.     }
  281.     chan = Tcl_GetStdChannel(TCL_STDOUT);
  282.     if (chan != (Tcl_Channel) NULL) {
  283.         Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan);
  284.     }
  285.     chan = Tcl_GetStdChannel(TCL_STDERR);
  286.     if (chan != (Tcl_Channel) NULL) {
  287.         Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan);
  288.     }
  289.     
  290.     return (Tcl_Interp *) iPtr;
  291. }
  292.  
  293. /*
  294.  *--------------------------------------------------------------
  295.  *
  296.  * Tcl_CallWhenDeleted --
  297.  *
  298.  *    Arrange for a procedure to be called before a given
  299.  *    interpreter is deleted. The procedure is called as soon
  300.  *    as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
  301.  *    called on an interpreter that has already been deleted,
  302.  *    the procedure will be called when the last Tcl_Release is
  303.  *    done on the interpreter.
  304.  *
  305.  * Results:
  306.  *    None.
  307.  *
  308.  * Side effects:
  309.  *    When Tcl_DeleteInterp is invoked to delete interp,
  310.  *    proc will be invoked.  See the manual entry for
  311.  *    details.
  312.  *
  313.  *--------------------------------------------------------------
  314.  */
  315.  
  316. void
  317. Tcl_CallWhenDeleted(interp, proc, clientData)
  318.     Tcl_Interp *interp;        /* Interpreter to watch. */
  319.     Tcl_InterpDeleteProc *proc;    /* Procedure to call when interpreter
  320.                  * is about to be deleted. */
  321.     ClientData clientData;    /* One-word value to pass to proc. */
  322. {
  323.     Interp *iPtr = (Interp *) interp;
  324.     static int assocDataCounter = 0;
  325.     int new;
  326.     char buffer[128];
  327.     AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
  328.     Tcl_HashEntry *hPtr;
  329.  
  330.     sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);
  331.     assocDataCounter++;
  332.  
  333.     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
  334.         iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
  335.         Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
  336.     }
  337.     hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
  338.     dPtr->proc = proc;
  339.     dPtr->clientData = clientData;
  340.     Tcl_SetHashValue(hPtr, dPtr);
  341. }
  342.  
  343. /*
  344.  *--------------------------------------------------------------
  345.  *
  346.  * Tcl_DontCallWhenDeleted --
  347.  *
  348.  *    Cancel the arrangement for a procedure to be called when
  349.  *    a given interpreter is deleted.
  350.  *
  351.  * Results:
  352.  *    None.
  353.  *
  354.  * Side effects:
  355.  *    If proc and clientData were previously registered as a
  356.  *    callback via Tcl_CallWhenDeleted, they are unregistered.
  357.  *    If they weren't previously registered then nothing
  358.  *    happens.
  359.  *
  360.  *--------------------------------------------------------------
  361.  */
  362.  
  363. void
  364. Tcl_DontCallWhenDeleted(interp, proc, clientData)
  365.     Tcl_Interp *interp;        /* Interpreter to watch. */
  366.     Tcl_InterpDeleteProc *proc;    /* Procedure to call when interpreter
  367.                  * is about to be deleted. */
  368.     ClientData clientData;    /* One-word value to pass to proc. */
  369. {
  370.     Interp *iPtr = (Interp *) interp;
  371.     Tcl_HashTable *hTablePtr;
  372.     Tcl_HashSearch hSearch;
  373.     Tcl_HashEntry *hPtr;
  374.     AssocData *dPtr;
  375.  
  376.     hTablePtr = iPtr->assocData;
  377.     if (hTablePtr == (Tcl_HashTable *) NULL) {
  378.         return;
  379.     }
  380.     for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
  381.         hPtr = Tcl_NextHashEntry(&hSearch)) {
  382.         dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
  383.         if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
  384.             ckfree((char *) dPtr);
  385.             Tcl_DeleteHashEntry(hPtr);
  386.             return;
  387.         }
  388.     }
  389. }
  390.  
  391. /*
  392.  *----------------------------------------------------------------------
  393.  *
  394.  * Tcl_SetAssocData --
  395.  *
  396.  *    Creates a named association between user-specified data, a delete
  397.  *    function and this interpreter. If the association already exists
  398.  *    the data is overwritten with the new data. The delete function will
  399.  *    be invoked when the interpreter is deleted.
  400.  *
  401.  * Results:
  402.  *    None.
  403.  *
  404.  * Side effects:
  405.  *    Sets the associated data, creates the association if needed.
  406.  *
  407.  *----------------------------------------------------------------------
  408.  */
  409.  
  410. void
  411. Tcl_SetAssocData(interp, name, proc, clientData)
  412.     Tcl_Interp *interp;        /* Interpreter to associate with. */
  413.     char *name;            /* Name for association. */
  414.     Tcl_InterpDeleteProc *proc;    /* Proc to call when interpreter is
  415.                                  * about to be deleted. */
  416.     ClientData clientData;    /* One-word value to pass to proc. */
  417. {
  418.     Interp *iPtr = (Interp *) interp;
  419.     AssocData *dPtr;
  420.     Tcl_HashEntry *hPtr;
  421.     int new;
  422.  
  423.     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
  424.         iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
  425.         Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
  426.     }
  427.     hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
  428.     if (new == 0) {
  429.         dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
  430.     } else {
  431.         dPtr = (AssocData *) ckalloc(sizeof(AssocData));
  432.     }
  433.     dPtr->proc = proc;
  434.     dPtr->clientData = clientData;
  435.  
  436.     Tcl_SetHashValue(hPtr, dPtr);
  437. }
  438.  
  439. /*
  440.  *----------------------------------------------------------------------
  441.  *
  442.  * Tcl_DeleteAssocData --
  443.  *
  444.  *    Deletes a named association of user-specified data with
  445.  *    the specified interpreter.
  446.  *
  447.  * Results:
  448.  *    None.
  449.  *
  450.  * Side effects:
  451.  *    Deletes the association.
  452.  *
  453.  *----------------------------------------------------------------------
  454.  */
  455.  
  456. void
  457. Tcl_DeleteAssocData(interp, name)
  458.     Tcl_Interp *interp;            /* Interpreter to associate with. */
  459.     char *name;                /* Name of association. */
  460. {
  461.     Interp *iPtr = (Interp *) interp;
  462.     AssocData *dPtr;
  463.     Tcl_HashEntry *hPtr;
  464.  
  465.     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
  466.         return;
  467.     }
  468.     hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
  469.     if (hPtr == (Tcl_HashEntry *) NULL) {
  470.         return;
  471.     }
  472.     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
  473.     if (dPtr->proc != NULL) {
  474.         (dPtr->proc) (dPtr->clientData, interp);
  475.     }
  476.     ckfree((char *) dPtr);
  477.     Tcl_DeleteHashEntry(hPtr);
  478. }
  479.  
  480. /*
  481.  *----------------------------------------------------------------------
  482.  *
  483.  * Tcl_GetAssocData --
  484.  *
  485.  *    Returns the client data associated with this name in the
  486.  *    specified interpreter.
  487.  *
  488.  * Results:
  489.  *    The client data in the AssocData record denoted by the named
  490.  *    association, or NULL.
  491.  *
  492.  * Side effects:
  493.  *    None.
  494.  *
  495.  *----------------------------------------------------------------------
  496.  */
  497.  
  498. ClientData
  499. Tcl_GetAssocData(interp, name, procPtr)
  500.     Tcl_Interp *interp;            /* Interpreter associated with. */
  501.     char *name;                /* Name of association. */
  502.     Tcl_InterpDeleteProc **procPtr;    /* Pointer to place to store address
  503.                      * of current deletion callback. */
  504. {
  505.     Interp *iPtr = (Interp *) interp;
  506.     AssocData *dPtr;
  507.     Tcl_HashEntry *hPtr;
  508.  
  509.     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
  510.         return (ClientData) NULL;
  511.     }
  512.     hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
  513.     if (hPtr == (Tcl_HashEntry *) NULL) {
  514.         return (ClientData) NULL;
  515.     }
  516.     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
  517.     if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
  518.         *procPtr = dPtr->proc;
  519.     }
  520.     return dPtr->clientData;
  521. }
  522.  
  523. /*
  524.  *----------------------------------------------------------------------
  525.  *
  526.  * DeleteInterpProc --
  527.  *
  528.  *    Helper procedure to delete an interpreter. This procedure is
  529.  *    called when the last call to Tcl_Preserve on this interpreter
  530.  *    is matched by a call to Tcl_Release. The procedure cleans up
  531.  *    all resources used in the interpreter and calls all currently
  532.  *    registered interpreter deletion callbacks.
  533.  *
  534.  * Results:
  535.  *    None.
  536.  *
  537.  * Side effects:
  538.  *    Whatever the interpreter deletion callbacks do. Frees resources
  539.  *    used by the interpreter.
  540.  *
  541.  *----------------------------------------------------------------------
  542.  */
  543.  
  544. static void
  545. DeleteInterpProc(interp)
  546.     Tcl_Interp *interp;            /* Interpreter to delete. */
  547. {
  548.     Interp *iPtr = (Interp *) interp;
  549.     Tcl_HashEntry *hPtr;
  550.     Tcl_HashSearch search;
  551.     int i;
  552.     Tcl_HashTable *hTablePtr;
  553.     AssocData *dPtr;
  554.  
  555.     /*
  556.      * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
  557.      */
  558.     
  559.     if (iPtr->numLevels > 0) {
  560.         panic("DeleteInterpProc called with active evals");
  561.     }
  562.  
  563.     /*
  564.      * The interpreter should already be marked deleted; otherwise how
  565.      * did we get here?
  566.      */
  567.  
  568.     if (!(iPtr->flags & DELETED)) {
  569.         panic("DeleteInterpProc called on interpreter not marked deleted");
  570.     }
  571.  
  572.     /*
  573.      * First delete all the commands.  There's a special hack here
  574.      * because "tkerror" is just a synonym for "bgerror" (they share
  575.      * a Command structure).  Just delete the hash table entry for
  576.      * "tkerror" without invoking its callback or cleaning up its
  577.      * Command structure.
  578.      */
  579.  
  580.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror");
  581.     if (hPtr != NULL) {
  582.     Tcl_DeleteHashEntry(hPtr);
  583.     }
  584.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  585.          hPtr != NULL;
  586.              hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search)) {
  587.         Tcl_DeleteCommand(interp,
  588.                 Tcl_GetHashKey(&iPtr->commandTable, hPtr));
  589.     }
  590.     Tcl_DeleteHashTable(&iPtr->commandTable);
  591.     for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
  592.          hPtr != NULL;
  593.              hPtr = Tcl_NextHashEntry(&search)) {
  594.     ckfree((char *) Tcl_GetHashValue(hPtr));
  595.     }
  596.     Tcl_DeleteHashTable(&iPtr->mathFuncTable);
  597.     
  598.     /*
  599.      * Invoke deletion callbacks; note that a callback can create new
  600.      * callbacks, so we iterate.
  601.      */
  602.  
  603.     while (iPtr->assocData != (Tcl_HashTable *) NULL) {
  604.         hTablePtr = iPtr->assocData;
  605.         iPtr->assocData = (Tcl_HashTable *) NULL;
  606.         for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
  607.                  hPtr != NULL;
  608.                  hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
  609.             dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
  610.             Tcl_DeleteHashEntry(hPtr);
  611.             if (dPtr->proc != NULL) {
  612.                 (*dPtr->proc)(dPtr->clientData, interp);
  613.             }
  614.             ckfree((char *) dPtr);
  615.         }
  616.         Tcl_DeleteHashTable(hTablePtr);
  617.         ckfree((char *) hTablePtr);
  618.     }
  619.  
  620.     /*
  621.      * Delete all global variables:
  622.      */
  623.     
  624.     TclDeleteVars(iPtr, &iPtr->globalTable);
  625.  
  626.     /*
  627.      * Free up the result *after* deleting variables, since variable
  628.      * deletion could have transferred ownership of the result string
  629.      * to Tcl.
  630.      */
  631.  
  632.     Tcl_FreeResult(interp);
  633.     interp->result = NULL;
  634.  
  635.     if (iPtr->errorInfo != NULL) {
  636.     ckfree(iPtr->errorInfo);
  637.         iPtr->errorInfo = NULL;
  638.     }
  639.     if (iPtr->errorCode != NULL) {
  640.     ckfree(iPtr->errorCode);
  641.         iPtr->errorCode = NULL;
  642.     }
  643.     if (iPtr->events != NULL) {
  644.     int i;
  645.  
  646.     for (i = 0; i < iPtr->numEvents; i++) {
  647.         ckfree(iPtr->events[i].command);
  648.     }
  649.     ckfree((char *) iPtr->events);
  650.         iPtr->events = NULL;
  651.     }
  652.     while (iPtr->revPtr != NULL) {
  653.     HistoryRev *nextPtr = iPtr->revPtr->nextPtr;
  654.  
  655.     ckfree(iPtr->revPtr->newBytes);
  656.     ckfree((char *) iPtr->revPtr);
  657.     iPtr->revPtr = nextPtr;
  658.     }
  659.     if (iPtr->appendResult != NULL) {
  660.     ckfree(iPtr->appendResult);
  661.         iPtr->appendResult = NULL;
  662.     }
  663.     for (i = 0; i < NUM_REGEXPS; i++) {
  664.     if (iPtr->patterns[i] == NULL) {
  665.         break;
  666.     }
  667.     ckfree(iPtr->patterns[i]);
  668.     ckfree((char *) iPtr->regexps[i]);
  669.         iPtr->regexps[i] = NULL;
  670.     }
  671.     TclFreePackageInfo(iPtr);
  672.     while (iPtr->tracePtr != NULL) {
  673.     Trace *nextPtr = iPtr->tracePtr->nextPtr;
  674.  
  675.     ckfree((char *) iPtr->tracePtr);
  676.     iPtr->tracePtr = nextPtr;
  677.     }
  678.  
  679.     ckfree((char *) iPtr);
  680. }
  681.  
  682. /*
  683.  *----------------------------------------------------------------------
  684.  *
  685.  * Tcl_InterpDeleted --
  686.  *
  687.  *    Returns nonzero if the interpreter has been deleted with a call
  688.  *    to Tcl_DeleteInterp.
  689.  *
  690.  * Results:
  691.  *    Nonzero if the interpreter is deleted, zero otherwise.
  692.  *
  693.  * Side effects:
  694.  *    None.
  695.  *
  696.  *----------------------------------------------------------------------
  697.  */
  698.  
  699. int
  700. Tcl_InterpDeleted(interp)
  701.     Tcl_Interp *interp;
  702. {
  703.     return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
  704. }
  705.  
  706. /*
  707.  *----------------------------------------------------------------------
  708.  *
  709.  * Tcl_DeleteInterp --
  710.  *
  711.  *    Ensures that the interpreter will be deleted eventually. If there
  712.  *    are no Tcl_Preserve calls in effect for this interpreter, it is
  713.  *    deleted immediately, otherwise the interpreter is deleted when
  714.  *    the last Tcl_Preserve is matched by a call to Tcl_Release. In either
  715.  *    case, the procedure runs the currently registered deletion callbacks. 
  716.  *
  717.  * Results:
  718.  *    None.
  719.  *
  720.  * Side effects:
  721.  *    The interpreter is marked as deleted. The caller may still use it
  722.  *    safely if there are calls to Tcl_Preserve in effect for the
  723.  *    interpreter, but further calls to Tcl_Eval etc in this interpreter
  724.  *    will fail.
  725.  *
  726.  *----------------------------------------------------------------------
  727.  */
  728.  
  729. void
  730. Tcl_DeleteInterp(interp)
  731.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  732.                  * by a previous call to Tcl_CreateInterp). */
  733. {
  734.     Interp *iPtr = (Interp *) interp;
  735.  
  736.     /*
  737.      * If the interpreter has already been marked deleted, just punt.
  738.      */
  739.  
  740.     if (iPtr->flags & DELETED) {
  741.         return;
  742.     }
  743.     
  744.     /*
  745.      * Mark the interpreter as deleted. No further evals will be allowed.
  746.      */
  747.  
  748.     iPtr->flags |= DELETED;
  749.  
  750.     /*
  751.      * Ensure that the interpreter is eventually deleted.
  752.      */
  753.  
  754.     Tcl_EventuallyFree((ClientData) interp,
  755.             (Tcl_FreeProc *) DeleteInterpProc);
  756. }
  757.  
  758. /*
  759.  *----------------------------------------------------------------------
  760.  *
  761.  * Tcl_CreateCommand --
  762.  *
  763.  *    Define a new command in a command table.
  764.  *
  765.  * Results:
  766.  *    The return value is a token for the command, which can
  767.  *    be used in future calls to Tcl_NameOfCommand.
  768.  *
  769.  * Side effects:
  770.  *    If a command named cmdName already exists for interp, it is
  771.  *    deleted.  In the future, when cmdName is seen as the name of
  772.  *    a command by Tcl_Eval, proc will be called.  When the command
  773.  *    is deleted from the table, deleteProc will be called.  See the
  774.  *    manual entry for details on the calling sequence.
  775.  *
  776.  *----------------------------------------------------------------------
  777.  */
  778.  
  779. Tcl_Command
  780. Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
  781.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  782.                  * by a previous call to Tcl_CreateInterp). */
  783.     char *cmdName;        /* Name of command. */
  784.     Tcl_CmdProc *proc;        /* Command procedure to associate with
  785.                  * cmdName. */
  786.     ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
  787.     Tcl_CmdDeleteProc *deleteProc;
  788.                 /* If not NULL, gives a procedure to call when
  789.                  * this command is deleted. */
  790. {
  791.     Interp *iPtr = (Interp *) interp;
  792.     Command *cmdPtr;
  793.     Tcl_HashEntry *hPtr;
  794.     int new;
  795.  
  796.     /*
  797.      * The code below was added in 11/95 to preserve backwards compatibility
  798.      * when "tkerror" was renamed "bgerror":  if anyone attempts to define
  799.      * "tkerror" as a command, it is actually created as "bgerror".  This
  800.      * code should eventually be removed.
  801.      */
  802.  
  803.     if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) {
  804.     cmdName = "bgerror";
  805.     }
  806.  
  807.     if (iPtr->flags & DELETED) {
  808.  
  809.     /*
  810.      * The interpreter is being deleted.  Don't create any new
  811.      * commands;  it's not safe to muck with the interpreter anymore.
  812.      */
  813.  
  814.     return (Tcl_Command) NULL;
  815.     }
  816.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
  817.     if (!new) {
  818.     /*
  819.      * Command already exists:  delete the old one.
  820.      */
  821.  
  822.     Tcl_DeleteCommand(interp, Tcl_GetHashKey(&iPtr->commandTable, hPtr));
  823.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
  824.     if (!new) {
  825.         /*
  826.          * Drat.  The stupid deletion callback recreated the command.
  827.          * Just throw away the new command (if we try to delete it again,
  828.          * we could get stuck in an infinite loop).
  829.          */
  830.  
  831.          ckfree((char  *) Tcl_GetHashValue(hPtr));
  832.      }
  833.     }
  834.     cmdPtr = (Command *) ckalloc(sizeof(Command));
  835.     Tcl_SetHashValue(hPtr, cmdPtr);
  836.     cmdPtr->hPtr = hPtr;
  837.     cmdPtr->proc = proc;
  838.     cmdPtr->clientData = clientData;
  839.     cmdPtr->deleteProc = deleteProc;
  840.     cmdPtr->deleteData = clientData;
  841.     cmdPtr->deleted = 0;
  842.  
  843.     /*
  844.      * The code below provides more backwards compatibility for the
  845.      * renaming of "tkerror" to "bgerror".  Like the code above, this
  846.      * code should eventually become unnecessary.
  847.      */
  848.  
  849.     if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) {
  850.     /*
  851.      * We're currently creating the "bgerror" command;  create
  852.      * a "tkerror" command that shares the same Command structure.
  853.      */
  854.  
  855.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new);
  856.     Tcl_SetHashValue(hPtr, cmdPtr);
  857.     }
  858.     return (Tcl_Command) cmdPtr;
  859. }
  860.  
  861. /*
  862.  *----------------------------------------------------------------------
  863.  *
  864.  * Tcl_SetCommandInfo --
  865.  *
  866.  *    Modifies various information about a Tcl command.
  867.  *
  868.  * Results:
  869.  *    If cmdName exists in interp, then the information at *infoPtr
  870.  *    is stored with the command in place of the current information
  871.  *    and 1 is returned.  If the command doesn't exist then 0 is
  872.  *    returned.
  873.  *
  874.  * Side effects:
  875.  *    None.
  876.  *
  877.  *----------------------------------------------------------------------
  878.  */
  879.  
  880. int
  881. Tcl_SetCommandInfo(interp, cmdName, infoPtr)
  882.     Tcl_Interp *interp;            /* Interpreter in which to look
  883.                      * for command. */
  884.     char *cmdName;            /* Name of desired command. */
  885.     Tcl_CmdInfo *infoPtr;        /* Where to store information about
  886.                      * command. */
  887. {
  888.     Tcl_HashEntry *hPtr;
  889.     Command *cmdPtr;
  890.  
  891.     hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName);
  892.     if (hPtr == NULL) {
  893.     return 0;
  894.     }
  895.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  896.     cmdPtr->proc = infoPtr->proc;
  897.     cmdPtr->clientData = infoPtr->clientData;
  898.     cmdPtr->deleteProc = infoPtr->deleteProc;
  899.     cmdPtr->deleteData = infoPtr->deleteData;
  900.     return 1;
  901. }
  902.  
  903. /*
  904.  *----------------------------------------------------------------------
  905.  *
  906.  * Tcl_GetCommandInfo --
  907.  *
  908.  *    Returns various information about a Tcl command.
  909.  *
  910.  * Results:
  911.  *    If cmdName exists in interp, then *infoPtr is modified to
  912.  *    hold information about cmdName and 1 is returned.  If the
  913.  *    command doesn't exist then 0 is returned and *infoPtr isn't
  914.  *    modified.
  915.  *
  916.  * Side effects:
  917.  *    None.
  918.  *
  919.  *----------------------------------------------------------------------
  920.  */
  921.  
  922. int
  923. Tcl_GetCommandInfo(interp, cmdName, infoPtr)
  924.     Tcl_Interp *interp;            /* Interpreter in which to look
  925.                      * for command. */
  926.     char *cmdName;            /* Name of desired command. */
  927.     Tcl_CmdInfo *infoPtr;        /* Where to store information about
  928.                      * command. */
  929. {
  930.     Tcl_HashEntry *hPtr;
  931.     Command *cmdPtr;
  932.  
  933.     hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName);
  934.     if (hPtr == NULL) {
  935.     return 0;
  936.     }
  937.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  938.     infoPtr->proc = cmdPtr->proc;
  939.     infoPtr->clientData = cmdPtr->clientData;
  940.     infoPtr->deleteProc = cmdPtr->deleteProc;
  941.     infoPtr->deleteData = cmdPtr->deleteData;
  942.     return 1;
  943. }
  944.  
  945. /*
  946.  *----------------------------------------------------------------------
  947.  *
  948.  * Tcl_GetCommandName --
  949.  *
  950.  *    Given a token returned by Tcl_CreateCommand, this procedure
  951.  *    returns the current name of the command (which may have changed
  952.  *    due to renaming).
  953.  *
  954.  * Results:
  955.  *    The return value is the name of the given command.
  956.  *
  957.  * Side effects:
  958.  *    None.
  959.  *
  960.  *----------------------------------------------------------------------
  961.  */
  962.  
  963. char *
  964. Tcl_GetCommandName(interp, command)
  965.     Tcl_Interp *interp;        /* Interpreter containing the command. */
  966.     Tcl_Command command;    /* Token for the command, returned by a
  967.                  * previous call to Tcl_CreateCommand.
  968.                  * The command must not have been deleted. */
  969. {
  970.     Command *cmdPtr = (Command *) command;
  971.     Interp *iPtr = (Interp *) interp;
  972.  
  973.     if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
  974.  
  975.     /*
  976.      * This should only happen if command was "created" after the
  977.      * interpreter began to be deleted, so there isn't really any
  978.      * command.  Just return an empty string.
  979.      */
  980.  
  981.     return "";
  982.     }
  983.     return Tcl_GetHashKey(&iPtr->commandTable, cmdPtr->hPtr);
  984. }
  985.  
  986. /*
  987.  *----------------------------------------------------------------------
  988.  *
  989.  * Tcl_DeleteCommand --
  990.  *
  991.  *    Remove the given command from the given interpreter.
  992.  *
  993.  * Results:
  994.  *    0 is returned if the command was deleted successfully.
  995.  *    -1 is returned if there didn't exist a command by that
  996.  *    name.
  997.  *
  998.  * Side effects:
  999.  *    CmdName will no longer be recognized as a valid command for
  1000.  *    interp.
  1001.  *
  1002.  *----------------------------------------------------------------------
  1003.  */
  1004.  
  1005. int
  1006. Tcl_DeleteCommand(interp, cmdName)
  1007.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  1008.                  * by a previous call to Tcl_CreateInterp). */
  1009.     char *cmdName;        /* Name of command to remove. */
  1010. {
  1011.     Interp *iPtr = (Interp *) interp;
  1012.     Tcl_HashEntry *hPtr, *tkErrorHPtr;
  1013.     Command *cmdPtr;
  1014.  
  1015.     /*
  1016.      * The code below was added in 11/95 to preserve backwards compatibility
  1017.      * when "tkerror" was renamed "bgerror":  if anyone attempts to delete
  1018.      * "tkerror", delete both it  and "bgerror".  This  code should
  1019.      * eventually be removed.
  1020.      */
  1021.  
  1022.     if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) {
  1023.     cmdName = "bgerror";
  1024.     }
  1025.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
  1026.     if (hPtr == NULL) {
  1027.     return -1;
  1028.     }
  1029.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  1030.  
  1031.     /*
  1032.      * The code here is tricky.  We can't delete the hash table entry
  1033.      * before invoking the deletion callback because there are cases
  1034.      * where the deletion callback needs to invoke the command (e.g.
  1035.      * object systems such as OTcl).  However, this means that the
  1036.      * callback could try to delete or rename the command.  The deleted
  1037.      * flag allows us to detect these cases and skip nested deletes.
  1038.      */
  1039.  
  1040.     if (cmdPtr->deleted) {
  1041.  
  1042.     /*
  1043.      * Another deletion is already in progress.  Remove the hash
  1044.      * table entry now, but don't invoke a callback or free the
  1045.      * command structure.
  1046.      */
  1047.  
  1048.         Tcl_DeleteHashEntry(cmdPtr->hPtr);
  1049.     cmdPtr->hPtr = NULL;
  1050.     return 0;
  1051.     }
  1052.     cmdPtr->deleted = 1;
  1053.     if (cmdPtr->deleteProc != NULL) {
  1054.     (*cmdPtr->deleteProc)(cmdPtr->deleteData);
  1055.     }
  1056.  
  1057.     /*
  1058.      * The code below provides more backwards compatibility for the
  1059.      * renaming of "tkerror" to "bgerror".  Like the code above, this
  1060.      * code should eventually become unnecessary.
  1061.      */
  1062.  
  1063.     if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) {
  1064.  
  1065.     /*
  1066.      * When the "bgerror" command is deleted, delete "tkerror"
  1067.      * as well.  It shared the same Command structure as "bgerror",
  1068.      * so all we have to do is throw away the hash table entry.
  1069.          * NOTE: we have to be careful since tkerror may already have
  1070.          * been deleted before bgerror.
  1071.      */
  1072.  
  1073.         tkErrorHPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror");
  1074.         if (tkErrorHPtr != (Tcl_HashEntry *) NULL) {
  1075.             Tcl_DeleteHashEntry(tkErrorHPtr);
  1076.         }
  1077.     }
  1078.  
  1079.     /*
  1080.      * Don't use hPtr to delete the hash entry here, because it's
  1081.      * possible that the deletion callback renamed the command.
  1082.      * Instead, use cmdPtr->hptr, and make sure that no-one else
  1083.      * has already deleted the hash entry.
  1084.      */
  1085.  
  1086.     if (cmdPtr->hPtr != NULL) {
  1087.     Tcl_DeleteHashEntry(cmdPtr->hPtr);
  1088.     }
  1089.     ckfree((char *) cmdPtr);
  1090.  
  1091.     return 0;
  1092. }
  1093.  
  1094. /*
  1095.  *-----------------------------------------------------------------
  1096.  *
  1097.  * Tcl_Eval --
  1098.  *
  1099.  *    Parse and execute a command in the Tcl language.
  1100.  *
  1101.  * Results:
  1102.  *    The return value is one of the return codes defined in tcl.hd
  1103.  *    (such as TCL_OK), and interp->result contains a string value
  1104.  *    to supplement the return code.  The value of interp->result
  1105.  *    will persist only until the next call to Tcl_Eval:  copy it or
  1106.  *    lose it! *TermPtr is filled in with the character just after
  1107.  *    the last one that was part of the command (usually a NULL
  1108.  *    character or a closing bracket).
  1109.  *
  1110.  * Side effects:
  1111.  *    Almost certainly;  depends on the command.
  1112.  *
  1113.  *-----------------------------------------------------------------
  1114.  */
  1115.  
  1116. int
  1117. Tcl_Eval(interp, cmd)
  1118.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  1119.                  * by a previous call to Tcl_CreateInterp). */
  1120.     char *cmd;            /* Pointer to TCL command to interpret. */
  1121. {
  1122.     /*
  1123.      * The storage immediately below is used to generate a copy
  1124.      * of the command, after all argument substitutions.  Pv will
  1125.      * contain the argv values passed to the command procedure.
  1126.      */
  1127.  
  1128. #   define NUM_CHARS 200
  1129.     char copyStorage[NUM_CHARS];
  1130.     ParseValue pv;
  1131.     char *oldBuffer;
  1132.  
  1133.     /*
  1134.      * This procedure generates an (argv, argc) array for the command,
  1135.      * It starts out with stack-allocated space but uses dynamically-
  1136.      * allocated storage to increase it if needed.
  1137.      */
  1138.  
  1139. #   define NUM_ARGS 10
  1140.     char *(argStorage[NUM_ARGS]);
  1141.     char **argv = argStorage;
  1142.     int argc;
  1143.     int argSize = NUM_ARGS;
  1144.  
  1145.     register char *src;            /* Points to current character
  1146.                      * in cmd. */
  1147.     char termChar;            /* Return when this character is found
  1148.                      * (either ']' or '\0').  Zero means
  1149.                      * that newlines terminate commands. */
  1150.     int flags;                /* Interp->evalFlags value when the
  1151.                      * procedure was called. */
  1152.     int result;                /* Return value. */
  1153.     register Interp *iPtr = (Interp *) interp;
  1154.     Tcl_HashEntry *hPtr;
  1155.     Command *cmdPtr;
  1156.     char *termPtr;            /* Contains character just after the
  1157.                      * last one in the command. */
  1158.     char *cmdStart;            /* Points to first non-blank char. in
  1159.                      * command (used in calling trace
  1160.                      * procedures). */
  1161.     char *ellipsis = "";        /* Used in setting errorInfo variable;
  1162.                      * set to "..." to indicate that not
  1163.                      * all of offending command is included
  1164.                      * in errorInfo.  "" means that the
  1165.                      * command is all there. */
  1166.     register Trace *tracePtr;
  1167.     int oldCount = iPtr->cmdCount;    /* Used to tell whether any commands
  1168.                      * at all were executed. */
  1169.  
  1170.     /*
  1171.      * Initialize the result to an empty string and clear out any
  1172.      * error information.  This makes sure that we return an empty
  1173.      * result if there are no commands in the command string.
  1174.      */
  1175.  
  1176.     Tcl_FreeResult((Tcl_Interp *) iPtr);
  1177.     iPtr->result = iPtr->resultSpace;
  1178.     iPtr->resultSpace[0] = 0;
  1179.     result = TCL_OK;
  1180.  
  1181.     /*
  1182.      * Initialize the area in which command copies will be assembled.
  1183.      */
  1184.  
  1185.     pv.buffer = copyStorage;
  1186.     pv.end = copyStorage + NUM_CHARS - 1;
  1187.     pv.expandProc = TclExpandParseValue;
  1188.     pv.clientData = (ClientData) NULL;
  1189.  
  1190.     src = cmd;
  1191.     flags = iPtr->evalFlags;
  1192.     iPtr->evalFlags = 0;
  1193.     if (flags & TCL_BRACKET_TERM) {
  1194.     termChar = ']';
  1195.     } else {
  1196.     termChar = 0;
  1197.     }
  1198.     termPtr = src;
  1199.     cmdStart = src;
  1200.  
  1201.     /*
  1202.      * Check depth of nested calls to Tcl_Eval:  if this gets too large,
  1203.      * it's probably because of an infinite loop somewhere.
  1204.      */
  1205.  
  1206.     iPtr->numLevels++;
  1207.     if (iPtr->numLevels > iPtr->maxNestingDepth) {
  1208.     iPtr->numLevels--;
  1209.     iPtr->result =  "too many nested calls to Tcl_Eval (infinite loop?)";
  1210.     iPtr->termPtr = termPtr;
  1211.     return TCL_ERROR;
  1212.     }
  1213.  
  1214.     /*
  1215.      * There can be many sub-commands (separated by semi-colons or
  1216.      * newlines) in one command string.  This outer loop iterates over
  1217.      * individual commands.
  1218.      */
  1219.  
  1220.     while (*src != termChar) {
  1221.  
  1222.         /*
  1223.          * If we have been deleted, return an error preventing further
  1224.          * evals.
  1225.          */
  1226.         
  1227.         if (iPtr->flags & DELETED) {
  1228.             Tcl_ResetResult(interp);
  1229.             interp->result = "attempt to call eval in deleted interpreter";
  1230.             Tcl_SetErrorCode(interp, "CORE", "IDELETE", interp->result,
  1231.                     (char *) NULL);
  1232.             iPtr->numLevels--;
  1233.             return TCL_ERROR;
  1234.         }
  1235.  
  1236.     iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET);
  1237.  
  1238.     /*
  1239.      * Skim off leading white space and semi-colons, and skip
  1240.      * comments.
  1241.      */
  1242.  
  1243.     while (1) {
  1244.         register char c = *src;
  1245.  
  1246.         if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) {
  1247.         break;
  1248.         }
  1249.         src += 1;
  1250.     }
  1251.     if (*src == '#') {
  1252.         while (*src != 0) {
  1253.         if (*src == '\\') {
  1254.             int length;
  1255.             Tcl_Backslash(src, &length);
  1256.             src += length;
  1257.         } else if (*src == '\n') {
  1258.             src++;
  1259.             termPtr = src;
  1260.             break;
  1261.         } else {
  1262.             src++;
  1263.         }
  1264.         }
  1265.         continue;
  1266.     }
  1267.     cmdStart = src;
  1268.  
  1269.     /*
  1270.      * Parse the words of the command, generating the argc and
  1271.      * argv for the command procedure.  May have to call
  1272.      * TclParseWords several times, expanding the argv array
  1273.      * between calls.
  1274.      */
  1275.  
  1276.     pv.next = oldBuffer = pv.buffer;
  1277.     argc = 0;
  1278.     while (1) {
  1279.         int newArgs, maxArgs;
  1280.         char **newArgv;
  1281.         int i;
  1282.  
  1283.         /*
  1284.          * Note:  the "- 2" below guarantees that we won't use the
  1285.          * last two argv slots here.  One is for a NULL pointer to
  1286.          * mark the end of the list, and the other is to leave room
  1287.          * for inserting the command name "unknown" as the first
  1288.          * argument (see below).
  1289.          */
  1290.  
  1291.         maxArgs = argSize - argc - 2;
  1292.         result = TclParseWords((Tcl_Interp *) iPtr, src, flags,
  1293.             maxArgs, &termPtr, &newArgs, &argv[argc], &pv);
  1294.         src = termPtr;
  1295.         if (result != TCL_OK) {
  1296.         ellipsis = "...";
  1297.         goto done;
  1298.         }
  1299.  
  1300.         /*
  1301.          * Careful!  Buffer space may have gotten reallocated while
  1302.          * parsing words.  If this happened, be sure to update all
  1303.          * of the older argv pointers to refer to the new space.
  1304.          */
  1305.  
  1306.         if (oldBuffer != pv.buffer) {
  1307.         int i;
  1308.  
  1309.         for (i = 0; i < argc; i++) {
  1310.             argv[i] = pv.buffer + (argv[i] - oldBuffer);
  1311.         }
  1312.         oldBuffer = pv.buffer;
  1313.         }
  1314.         argc += newArgs;
  1315.         if (newArgs < maxArgs) {
  1316.         argv[argc] = (char *) NULL;
  1317.         break;
  1318.         }
  1319.  
  1320.         /*
  1321.          * Args didn't all fit in the current array.  Make it bigger.
  1322.          */
  1323.  
  1324.         argSize *= 2;
  1325.         newArgv = (char **)
  1326.             ckalloc((unsigned) argSize * sizeof(char *));
  1327.         for (i = 0; i < argc; i++) {
  1328.         newArgv[i] = argv[i];
  1329.         }
  1330.         if (argv != argStorage) {
  1331.         ckfree((char *) argv);
  1332.         }
  1333.         argv = newArgv;
  1334.     }
  1335.  
  1336.     /*
  1337.      * If this is an empty command (or if we're just parsing
  1338.      * commands without evaluating them), then just skip to the
  1339.      * next command.
  1340.      */
  1341.  
  1342.     if ((argc == 0) || iPtr->noEval) {
  1343.         continue;
  1344.     }
  1345.     argv[argc] = NULL;
  1346.  
  1347.     /*
  1348.      * Save information for the history module, if needed.
  1349.      */
  1350.  
  1351.     if (flags & TCL_RECORD_BOUNDS) {
  1352.         iPtr->evalFirst = cmdStart;
  1353.         iPtr->evalLast = src-1;
  1354.     }
  1355.  
  1356.     /*
  1357.      * Find the procedure to execute this command.  If there isn't
  1358.      * one, then see if there is a command "unknown".  If so,
  1359.      * invoke it instead, passing it the words of the original
  1360.      * command as arguments.
  1361.      */
  1362.  
  1363.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]);
  1364.     if (hPtr == NULL) {
  1365.         int i;
  1366.  
  1367.         hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown");
  1368.         if (hPtr == NULL) {
  1369.         Tcl_ResetResult(interp);
  1370.         Tcl_AppendResult(interp, "invalid command name \"",
  1371.             argv[0], "\"", (char *) NULL);
  1372.         result = TCL_ERROR;
  1373.         goto done;
  1374.         }
  1375.         for (i = argc; i >= 0; i--) {
  1376.         argv[i+1] = argv[i];
  1377.         }
  1378.         argv[0] = "unknown";
  1379.         argc++;
  1380.     }
  1381.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  1382.  
  1383.     /*
  1384.      * Call trace procedures, if any.
  1385.      */
  1386.  
  1387.     for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
  1388.         tracePtr = tracePtr->nextPtr) {
  1389.         char saved;
  1390.  
  1391.         if (tracePtr->level < iPtr->numLevels) {
  1392.         continue;
  1393.         }
  1394.         saved = *src;
  1395.         *src = 0;
  1396.         (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
  1397.             cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
  1398.         *src = saved;
  1399.     }
  1400.  
  1401.     /*
  1402.      * At long last, invoke the command procedure.  Reset the
  1403.      * result to its default empty value first (it could have
  1404.      * gotten changed by earlier commands in the same command
  1405.      * string).
  1406.      */
  1407.  
  1408.     iPtr->cmdCount++;
  1409.     Tcl_FreeResult(iPtr);
  1410.     iPtr->result = iPtr->resultSpace;
  1411.     iPtr->resultSpace[0] = 0;
  1412.     result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);
  1413.     if (Tcl_AsyncReady()) {
  1414.         result = Tcl_AsyncInvoke(interp, result);
  1415.     }
  1416.     if (result != TCL_OK) {
  1417.         break;
  1418.     }
  1419.     }
  1420.  
  1421.     done:
  1422.  
  1423.     /*
  1424.      * If no commands at all were executed, check for asynchronous
  1425.      * handlers so that they at least get one change to execute.
  1426.      * This is needed to handle event loops written in Tcl with
  1427.      * empty bodies (I'm not sure that loops like this are a good
  1428.      * idea, * but...).
  1429.      */
  1430.  
  1431.     if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) {
  1432.     result = Tcl_AsyncInvoke(interp, result);
  1433.     }
  1434.  
  1435.     /*
  1436.      * Free up any extra resources that were allocated.
  1437.      */
  1438.  
  1439.     if (pv.buffer != copyStorage) {
  1440.     ckfree((char *) pv.buffer);
  1441.     }
  1442.     if (argv != argStorage) {
  1443.     ckfree((char *) argv);
  1444.     }
  1445.     iPtr->numLevels--;
  1446.     if (iPtr->numLevels == 0) {
  1447.     if (result == TCL_RETURN) {
  1448.         result = TclUpdateReturnInfo(iPtr);
  1449.     }
  1450.     if ((result != TCL_OK) && (result != TCL_ERROR)
  1451.         && !(flags & TCL_ALLOW_EXCEPTIONS)) {
  1452.         Tcl_ResetResult(interp);
  1453.         if (result == TCL_BREAK) {
  1454.         iPtr->result = "invoked \"break\" outside of a loop";
  1455.         } else if (result == TCL_CONTINUE) {
  1456.         iPtr->result = "invoked \"continue\" outside of a loop";
  1457.         } else {
  1458.         iPtr->result = iPtr->resultSpace;
  1459.         sprintf(iPtr->resultSpace, "command returned bad code: %d",
  1460.             result);
  1461.         }
  1462.         result = TCL_ERROR;
  1463.     }
  1464.     }
  1465.  
  1466.     /*
  1467.      * If an error occurred, record information about what was being
  1468.      * executed when the error occurred.
  1469.      */
  1470.  
  1471.     if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
  1472.     int numChars;
  1473.     register char *p;
  1474.  
  1475.     /*
  1476.      * Compute the line number where the error occurred.
  1477.      */
  1478.  
  1479.     iPtr->errorLine = 1;
  1480.     for (p = cmd; p != cmdStart; p++) {
  1481.         if (*p == '\n') {
  1482.         iPtr->errorLine++;
  1483.         }
  1484.     }
  1485.     for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) {
  1486.         if (*p == '\n') {
  1487.         iPtr->errorLine++;
  1488.         }
  1489.     }
  1490.  
  1491.     /*
  1492.      * Figure out how much of the command to print in the error
  1493.      * message (up to a certain number of characters, or up to
  1494.      * the first new-line).
  1495.      */
  1496.  
  1497.     numChars = src - cmdStart;
  1498.     if (numChars > (NUM_CHARS-50)) {
  1499.         numChars = NUM_CHARS-50;
  1500.         ellipsis = " ...";
  1501.     }
  1502.  
  1503.     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
  1504.         sprintf(copyStorage, "\n    while executing\n\"%.*s%s\"",
  1505.             numChars, cmdStart, ellipsis);
  1506.     } else {
  1507.         sprintf(copyStorage, "\n    invoked from within\n\"%.*s%s\"",
  1508.             numChars, cmdStart, ellipsis);
  1509.     }
  1510.     Tcl_AddErrorInfo(interp, copyStorage);
  1511.     iPtr->flags &= ~ERR_ALREADY_LOGGED;
  1512.     } else {
  1513.     iPtr->flags &= ~ERR_ALREADY_LOGGED;
  1514.     }
  1515.     iPtr->termPtr = termPtr;
  1516.     return result;
  1517. }
  1518.  
  1519. /*
  1520.  *----------------------------------------------------------------------
  1521.  *
  1522.  * Tcl_CreateTrace --
  1523.  *
  1524.  *    Arrange for a procedure to be called to trace command execution.
  1525.  *
  1526.  * Results:
  1527.  *    The return value is a token for the trace, which may be passed
  1528.  *    to Tcl_DeleteTrace to eliminate the trace.
  1529.  *
  1530.  * Side effects:
  1531.  *    From now on, proc will be called just before a command procedure
  1532.  *    is called to execute a Tcl command.  Calls to proc will have the
  1533.  *    following form:
  1534.  *
  1535.  *    void
  1536.  *    proc(clientData, interp, level, command, cmdProc, cmdClientData,
  1537.  *        argc, argv)
  1538.  *        ClientData clientData;
  1539.  *        Tcl_Interp *interp;
  1540.  *        int level;
  1541.  *        char *command;
  1542.  *        int (*cmdProc)();
  1543.  *        ClientData cmdClientData;
  1544.  *        int argc;
  1545.  *        char **argv;
  1546.  *    {
  1547.  *    }
  1548.  *
  1549.  *    The clientData and interp arguments to proc will be the same
  1550.  *    as the corresponding arguments to this procedure.  Level gives
  1551.  *    the nesting level of command interpretation for this interpreter
  1552.  *    (0 corresponds to top level).  Command gives the ASCII text of
  1553.  *    the raw command, cmdProc and cmdClientData give the procedure that
  1554.  *    will be called to process the command and the ClientData value it
  1555.  *    will receive, and argc and argv give the arguments to the
  1556.  *    command, after any argument parsing and substitution.  Proc
  1557.  *    does not return a value.
  1558.  *
  1559.  *----------------------------------------------------------------------
  1560.  */
  1561.  
  1562. Tcl_Trace
  1563. Tcl_CreateTrace(interp, level, proc, clientData)
  1564.     Tcl_Interp *interp;        /* Interpreter in which to create the trace. */
  1565.     int level;            /* Only call proc for commands at nesting level
  1566.                  * <= level (1 => top level). */
  1567.     Tcl_CmdTraceProc *proc;    /* Procedure to call before executing each
  1568.                  * command. */
  1569.     ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
  1570. {
  1571.     register Trace *tracePtr;
  1572.     register Interp *iPtr = (Interp *) interp;
  1573.  
  1574.     tracePtr = (Trace *) ckalloc(sizeof(Trace));
  1575.     tracePtr->level = level;
  1576.     tracePtr->proc = proc;
  1577.     tracePtr->clientData = clientData;
  1578.     tracePtr->nextPtr = iPtr->tracePtr;
  1579.     iPtr->tracePtr = tracePtr;
  1580.  
  1581.     return (Tcl_Trace) tracePtr;
  1582. }
  1583.  
  1584. /*
  1585.  *----------------------------------------------------------------------
  1586.  *
  1587.  * Tcl_DeleteTrace --
  1588.  *
  1589.  *    Remove a trace.
  1590.  *
  1591.  * Results:
  1592.  *    None.
  1593.  *
  1594.  * Side effects:
  1595.  *    From now on there will be no more calls to the procedure given
  1596.  *    in trace.
  1597.  *
  1598.  *----------------------------------------------------------------------
  1599.  */
  1600.  
  1601. void
  1602. Tcl_DeleteTrace(interp, trace)
  1603.     Tcl_Interp *interp;        /* Interpreter that contains trace. */
  1604.     Tcl_Trace trace;        /* Token for trace (returned previously by
  1605.                  * Tcl_CreateTrace). */
  1606. {
  1607.     register Interp *iPtr = (Interp *) interp;
  1608.     register Trace *tracePtr = (Trace *) trace;
  1609.     register Trace *tracePtr2;
  1610.  
  1611.     if (iPtr->tracePtr == tracePtr) {
  1612.     iPtr->tracePtr = tracePtr->nextPtr;
  1613.     ckfree((char *) tracePtr);
  1614.     } else {
  1615.     for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
  1616.         tracePtr2 = tracePtr2->nextPtr) {
  1617.         if (tracePtr2->nextPtr == tracePtr) {
  1618.         tracePtr2->nextPtr = tracePtr->nextPtr;
  1619.         ckfree((char *) tracePtr);
  1620.         return;
  1621.         }
  1622.     }
  1623.     }
  1624. }
  1625.  
  1626. /*
  1627.  *----------------------------------------------------------------------
  1628.  *
  1629.  * Tcl_AddErrorInfo --
  1630.  *
  1631.  *    Add information to a message being accumulated that describes
  1632.  *    the current error.
  1633.  *
  1634.  * Results:
  1635.  *    None.
  1636.  *
  1637.  * Side effects:
  1638.  *    The contents of message are added to the "errorInfo" variable.
  1639.  *    If Tcl_Eval has been called since the current value of errorInfo
  1640.  *    was set, errorInfo is cleared before adding the new message.
  1641.  *
  1642.  *----------------------------------------------------------------------
  1643.  */
  1644.  
  1645. void
  1646. Tcl_AddErrorInfo(interp, message)
  1647.     Tcl_Interp *interp;        /* Interpreter to which error information
  1648.                  * pertains. */
  1649.     char *message;        /* Message to record. */
  1650. {
  1651.     register Interp *iPtr = (Interp *) interp;
  1652.  
  1653.     /*
  1654.      * If an error is already being logged, then the new errorInfo
  1655.      * is the concatenation of the old info and the new message.
  1656.      * If this is the first piece of info for the error, then the
  1657.      * new errorInfo is the concatenation of the message in
  1658.      * interp->result and the new message.
  1659.      */
  1660.  
  1661.     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
  1662.     Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
  1663.         TCL_GLOBAL_ONLY);
  1664.     iPtr->flags |= ERR_IN_PROGRESS;
  1665.  
  1666.     /*
  1667.      * If the errorCode variable wasn't set by the code that generated
  1668.      * the error, set it to "NONE".
  1669.      */
  1670.  
  1671.     if (!(iPtr->flags & ERROR_CODE_SET)) {
  1672.         (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
  1673.             TCL_GLOBAL_ONLY);
  1674.     }
  1675.     }
  1676.     Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message,
  1677.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
  1678. }
  1679.  
  1680. /*
  1681.  *----------------------------------------------------------------------
  1682.  *
  1683.  * Tcl_VarEval --
  1684.  *
  1685.  *    Given a variable number of string arguments, concatenate them
  1686.  *    all together and execute the result as a Tcl command.
  1687.  *
  1688.  * Results:
  1689.  *    A standard Tcl return result.  An error message or other
  1690.  *    result may be left in interp->result.
  1691.  *
  1692.  * Side effects:
  1693.  *    Depends on what was done by the command.
  1694.  *
  1695.  *----------------------------------------------------------------------
  1696.  */
  1697.     /* VARARGS2 */ /* ARGSUSED */
  1698. int
  1699. Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
  1700. {
  1701.     va_list argList;
  1702.     Tcl_DString buf;
  1703.     char *string;
  1704.     Tcl_Interp *interp;
  1705.     int result;
  1706.  
  1707.     /*
  1708.      * Copy the strings one after the other into a single larger
  1709.      * string.  Use stack-allocated space for small commands, but if
  1710.      * the command gets too large than call ckalloc to create the
  1711.      * space.
  1712.      */
  1713.  
  1714.     interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
  1715.     Tcl_DStringInit(&buf);
  1716.     while (1) {
  1717.     string = va_arg(argList, char *);
  1718.     if (string == NULL) {
  1719.         break;
  1720.     }
  1721.     Tcl_DStringAppend(&buf, string, -1);
  1722.     }
  1723.     va_end(argList);
  1724.  
  1725.     result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
  1726.     Tcl_DStringFree(&buf);
  1727.     return result;
  1728. }
  1729.  
  1730. /*
  1731.  *----------------------------------------------------------------------
  1732.  *
  1733.  * Tcl_GlobalEval --
  1734.  *
  1735.  *    Evaluate a command at global level in an interpreter.
  1736.  *
  1737.  * Results:
  1738.  *    A standard Tcl result is returned, and interp->result is
  1739.  *    modified accordingly.
  1740.  *
  1741.  * Side effects:
  1742.  *    The command string is executed in interp, and the execution
  1743.  *    is carried out in the variable context of global level (no
  1744.  *    procedures active), just as if an "uplevel #0" command were
  1745.  *    being executed.
  1746.  *
  1747.  *----------------------------------------------------------------------
  1748.  */
  1749.  
  1750. int
  1751. Tcl_GlobalEval(interp, command)
  1752.     Tcl_Interp *interp;        /* Interpreter in which to evaluate command. */
  1753.     char *command;        /* Command to evaluate. */
  1754. {
  1755.     register Interp *iPtr = (Interp *) interp;
  1756.     int result;
  1757.     CallFrame *savedVarFramePtr;
  1758.  
  1759.     savedVarFramePtr = iPtr->varFramePtr;
  1760.     iPtr->varFramePtr = NULL;
  1761.     result = Tcl_Eval(interp, command);
  1762.     iPtr->varFramePtr = savedVarFramePtr;
  1763.     return result;
  1764. }
  1765.  
  1766. /*
  1767.  *----------------------------------------------------------------------
  1768.  *
  1769.  * Tcl_SetRecursionLimit --
  1770.  *
  1771.  *    Set the maximum number of recursive calls that may be active
  1772.  *    for an interpreter at once.
  1773.  *
  1774.  * Results:
  1775.  *    The return value is the old limit on nesting for interp.
  1776.  *
  1777.  * Side effects:
  1778.  *    None.
  1779.  *
  1780.  *----------------------------------------------------------------------
  1781.  */
  1782.  
  1783. int
  1784. Tcl_SetRecursionLimit(interp, depth)
  1785.     Tcl_Interp *interp;            /* Interpreter whose nesting limit
  1786.                      * is to be set. */
  1787.     int depth;                /* New value for maximimum depth. */
  1788. {
  1789.     Interp *iPtr = (Interp *) interp;
  1790.     int old;
  1791.  
  1792.     old = iPtr->maxNestingDepth;
  1793.     if (depth > 0) {
  1794.     iPtr->maxNestingDepth = depth;
  1795.     }
  1796.     return old;
  1797. }
  1798.  
  1799. /*
  1800.  *----------------------------------------------------------------------
  1801.  *
  1802.  * Tcl_AllowExceptions --
  1803.  *
  1804.  *    Sets a flag in an interpreter so that exceptions can occur
  1805.  *    in the next call to Tcl_Eval without them being turned into
  1806.  *    errors.
  1807.  *
  1808.  * Results:
  1809.  *    None.
  1810.  *
  1811.  * Side effects:
  1812.  *    The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
  1813.  *    evalFlags structure.  See the reference documentation for
  1814.  *    more details.
  1815.  *
  1816.  *----------------------------------------------------------------------
  1817.  */
  1818.  
  1819. void
  1820. Tcl_AllowExceptions(interp)
  1821.     Tcl_Interp *interp;        /* Interpreter in which to set flag. */
  1822. {
  1823.     Interp *iPtr = (Interp *) interp;
  1824.  
  1825.     iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
  1826. }
  1827.