git.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxclp.c

   1 /*
   2  * tclXcmdloop --
   3  *
   4  *   Interactive command loop, C and Tcl callable.
   5  *-----------------------------------------------------------------------------
   6  * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
   7  *
   8  * Permission to use, copy, modify, and distribute this software and its
   9  * documentation for any purpose and without fee is hereby granted, provided
  10  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  11  * Mark Diekhans make no representations about the suitability of this
  12  * software for any purpose.  It is provided "as is" without express or
  13  * implied warranty.
  14  *-----------------------------------------------------------------------------
  15  * $Id: tclXcmdloop.c,v 2.0 1992/10/16 04:50:29 markd Rel $
  16  *-----------------------------------------------------------------------------
  17  */
  18
  19 #include "tclxint.h"
  20
  21
  22 /*
  23  * Pointer to eval procedure to use.  This way bring in the history module
  24  * from a library can be made optional.  This only works because the calling
  25  * sequence of Tcl_Eval is a superset of Tcl_RecordAndEval.  This defaults
  26  * to no history, set this variable to Tcl_RecordAndEval to use history.
  27  */
  28
  29 int (*tclShellCmdEvalProc) () = Tcl_Eval;
  30
  31 /*
  32  * Prototypes of internal functions.
  33  */
  34 static int
  35 IsSetVarCmd _ANSI_ARGS_((Tcl_Interp *interp,
  36                          char       *command));
  37
  38 static void
  39 OutFlush _ANSI_ARGS_((FILE *filePtr));
  40
  41 static void
  42 Tcl_PrintResult _ANSI_ARGS_((FILE   *fp,
  43                              int     returnval,
  44                              char   *resultText));
  45
  46 static void
  47 OutputPrompt _ANSI_ARGS_((Tcl_Interp *interp,
  48                           FILE       *outFP,
  49                           int         topLevel));
  50
  51 static int
  52 SetPromptVar _ANSI_ARGS_((Tcl_Interp  *interp,
  53                           char        *hookVarName,
  54                           char        *newHookValue,
  55                           char       **oldHookValuePtr));
  56
  57 \f
  58 /*
  59  *-----------------------------------------------------------------------------
  60  *
  61  * IsSetVarCmd --
  62  *
  63  *      Determine if the current command is a `set' command that set
  64  *      a variable (i.e. two arguments).  This routine should only be
  65  *      called if the command returned TCL_OK.
  66  *
  67  *-----------------------------------------------------------------------------
  68  */
  69 static int
  70 IsSetVarCmd (interp, command)
  71     Tcl_Interp *interp;
  72     char       *command;
  73 {
  74     char  *nextPtr;
  75
  76     if ((!STRNEQU (command, "set", 3)) || (!isspace (command [3])))
  77         return FALSE;  /* Quick check */
  78
  79     nextPtr = TclWordEnd (command, FALSE);
  80     if (*nextPtr == '\0')
  81         return FALSE;
  82     nextPtr = TclWordEnd (nextPtr, FALSE);
  83     if (*nextPtr == '\0')
  84         return FALSE;
  85
  86     while (*nextPtr != '\0') {
  87         if (!isspace (*nextPtr))
  88             return TRUE;
  89         nextPtr++;
  90     }
  91     return FALSE;
  92 }
  93 \f
  94 /*
  95  *-----------------------------------------------------------------------------
  96  *
  97  * OutFlush --
  98  *
  99  *   Flush a stdio file and check for errors.
 100  *
 101  *-----------------------------------------------------------------------------
 102  */
 103 static void
 104 OutFlush (filePtr)
 105     FILE *filePtr;
 106 {
 107     int stat;
 108
 109     stat = fflush (filePtr);
 110     if (ferror (filePtr)) {
 111         if (errno != EINTR)
 112             panic ("command loop: error writing to output file: %s\n",
 113                    strerror (errno));
 114         clearerr (filePtr);
 115     }
 116 }
 117 \f
 118 /*
 119  *-----------------------------------------------------------------------------
 120  *
 121  * Tcl_PrintResult --
 122  *
 123  *      Print a Tcl result
 124  *
 125  * Results:
 126  *
 127  *      Takes an open file pointer, a return value and some result
 128  *      text.  Prints the result text if the return value is TCL_OK,
 129  *      prints "Error:" and the result text if it's TCL_ERROR,
 130  *      else prints "Bad return code:" and the result text.
 131  *
 132  *-----------------------------------------------------------------------------
 133  */
 134 static void
 135 Tcl_PrintResult (fp, returnval, resultText)
 136     FILE   *fp;
 137     int     returnval;
 138     char   *resultText;
 139 {
 140
 141     if (returnval == TCL_OK) {
 142         if (resultText [0] != '\0') {
 143             fputs (resultText, fp);
 144             fputs ("\n", fp);
 145         }
 146     } else {
 147         OutFlush (fp);
 148         fputs ((returnval == TCL_ERROR) ? "Error" : "Bad return code", stderr);
 149         fputs (": ", stderr);
 150         fputs (resultText, stderr);
 151         fputs ("\n", stderr);
 152         OutFlush (stderr);
 153     }
 154 }
 155 \f
 156 /*
 157  *-----------------------------------------------------------------------------
 158  *
 159  * OutputPromp --
 160  *     Outputs a prompt by executing either the command string in
 161  *     TCLENV(topLevelPromptHook) or TCLENV(downLevelPromptHook).
 162  *
 163  *-----------------------------------------------------------------------------
 164  */
 165 static void
 166 OutputPrompt (interp, outFP, topLevel)
 167     Tcl_Interp *interp;
 168     FILE       *outFP;
 169     int         topLevel;
 170 {
 171     char *hookName;
 172     char *promptHook;
 173     int   result;
 174     int   promptDone = FALSE;
 175
 176     hookName = topLevel ? "topLevelPromptHook"
 177                         : "downLevelPromptHook";
 178
 179     promptHook = Tcl_GetVar2 (interp, "TCLENV", hookName, 1);
 180     if ((promptHook != NULL) && (promptHook [0] != '\0')) {
 181         result = Tcl_Eval (interp, promptHook, 0, (char **)NULL);
 182         if (!((result == TCL_OK) || (result == TCL_RETURN))) {
 183             fputs ("Error in prompt hook: ", stderr);
 184             fputs (interp->result, stderr);
 185             fputs ("\n", stderr);
 186             Tcl_PrintResult (outFP, result, interp->result);
 187         } else {
 188             fputs (interp->result, outFP);
 189             promptDone = TRUE;
 190         }
 191     }
 192     if (!promptDone) {
 193         if (topLevel)
 194             fputs ("%", outFP);
 195         else
 196             fputs (">", outFP);
 197     }
 198     OutFlush (outFP);
 199
 200 }
 201 \f
 202 /*
 203  *-----------------------------------------------------------------------------
 204  *
 205  * Tcl_CommandLoop --
 206  *
 207  *   Run a Tcl command loop.  The command loop interactively prompts for,
 208  * reads and executes commands. Two entries in the global array TCLENV
 209  * contain prompt hooks.  A prompt hook is Tcl code that is executed and
 210  * its result is used as the prompt string.  The element `topLevelPromptHook'
 211  * is the hook that generates the main prompt.  The element
 212  * `downLevelPromptHook' is the hook to generate the prompt for reading
 213  * continuation lines for incomplete commands.  If a signal occurs while
 214  * in the command loop, it is reset and ignored.  EOF terminates the loop.
 215  *
 216  * Parameters:
 217  *   o interp (I) - A pointer to the interpreter
 218  *   o inFile (I) - The file to read commands from.
 219  *   o outFile (I) - The file to write the prompts to.
 220  *   o evalProc (I) - The function to call to evaluate a command.
 221  *     Should be either Tcl_Eval or Tcl_RecordAndEval if history is desired.
 222  *   o options (I) - Currently unused.
 223  *-----------------------------------------------------------------------------
 224  */
 225 void
 226 Tcl_CommandLoop (interp, inFile, outFile, evalProc, options)
 227     Tcl_Interp *interp;
 228     FILE       *inFile;
 229     FILE       *outFile;
 230     int         (*evalProc) ();
 231     unsigned    options;
 232 {
 233     Tcl_CmdBuf cmdBuf;
 234     char       inputBuf[256];
 235     int        topLevel = TRUE;
 236     int        result;
 237     char      *cmd;
 238
 239     cmdBuf = Tcl_CreateCmdBuf();
 240
 241     while (TRUE) {
 242         /*
 243          * If a signal came in, process it and drop any pending command.
 244          */
 245         if (tclReceivedSignal) {
 246             Tcl_CheckForSignal (interp, TCL_OK);
 247             Tcl_DeleteCmdBuf(cmdBuf);
 248             cmdBuf = Tcl_CreateCmdBuf();
 249             topLevel = TRUE;
 250         }
 251         /*
 252          * Output a prompt and input a command.
 253          */
 254         clearerr (inFile);
 255         clearerr (outFile);
 256         OutputPrompt (interp, outFile, topLevel);
 257         errno = 0;
 258         if (fgets (inputBuf, sizeof (inputBuf), inFile) == NULL) {
 259             if (!feof(inFile) && (errno == EINTR)) {
 260                 putchar('\n');
 261                 continue;  /* Next command */
 262             }
 263             if (ferror (inFile))
 264                 panic ("command loop: error on input file: %s\n",
 265                        strerror (errno));
 266             goto endOfFile;
 267         }
 268         cmd = Tcl_AssembleCmd(cmdBuf, inputBuf);
 269
 270         if (cmd == NULL) {
 271             topLevel = FALSE;
 272             continue;  /* Next line */
 273         }
 274         /*
 275          * Finally have a complete command, go eval it and maybe output the
 276          * result.
 277          */
 278         result = (*evalProc) (interp, cmd, 0, (char **)NULL);
 279         if (result != TCL_OK || !IsSetVarCmd (interp, cmd))
 280             Tcl_PrintResult (outFile, result, interp->result);
 281         topLevel = TRUE;
 282     }
 283 endOfFile:
 284     Tcl_DeleteCmdBuf(cmdBuf);
 285 }
 286 \f
 287 /*
 288  *-----------------------------------------------------------------------------
 289  *
 290  * SetPromptVar --
 291  *     Set one of the prompt hook variables, saving a copy of the old
 292  *     value, if it exists.
 293  *
 294  * Parameters:
 295  *   o hookVarName (I) - The name of the prompt hook, which is an element
 296  *     of the TCLENV array.  One of topLevelPromptHook or downLevelPromptHook.
 297  *   o newHookValue (I) - The new value for the prompt hook.
 298  *   o oldHookValuePtr (O) - If not NULL, then a pointer to a copy of the
 299  *     old prompt value is returned here.  NULL is returned if there was not
 300  *     old value.  This is a pointer to a malloc-ed string that must be
 301  *     freed when no longer needed.
 302  * Result:
 303  *   TCL_OK if the hook variable was set ok, TCL_ERROR if an error occured.
 304  *-----------------------------------------------------------------------------
 305  */
 306 static int
 307 SetPromptVar (interp, hookVarName, newHookValue, oldHookValuePtr)
 308     Tcl_Interp *interp;
 309     char       *hookVarName;
 310     char       *newHookValue;
 311     char      **oldHookValuePtr;
 312 {
 313     char *hookValue;
 314     char *oldHookPtr = NULL;
 315
 316     if (oldHookValuePtr != NULL) {
 317         hookValue = Tcl_GetVar2 (interp, "TCLENV", hookVarName,
 318                                  TCL_GLOBAL_ONLY);
 319         if (hookValue != NULL) {
 320             oldHookPtr = ckalloc (strlen (hookValue) + 1);
 321             strcpy (oldHookPtr, hookValue);
 322         }
 323     }
 324     if (Tcl_SetVar2 (interp, "TCLENV", hookVarName, newHookValue,
 325                      TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
 326         if (oldHookPtr != NULL)
 327             ckfree (oldHookPtr);
 328         return TCL_ERROR;
 329     }
 330     if (oldHookValuePtr != NULL)
 331         *oldHookValuePtr = oldHookPtr;
 332     return TCL_OK;
 333 }
 334 \f
 335 /*
 336  *-----------------------------------------------------------------------------
 337  *
 338  * Tcl_CommandloopCmd --
 339  *     Implements the TCL commandloop command:
 340  *       commandloop prompt prompt2
 341  *
 342  * Results:
 343  *     Standard TCL results.
 344  *
 345  *-----------------------------------------------------------------------------
 346  */
 347 int
 348 Tcl_CommandloopCmd(clientData, interp, argc, argv)
 349     ClientData  clientData;
 350     Tcl_Interp *interp;
 351     int         argc;
 352     char      **argv;
 353 {
 354     char *oldTopLevelHook  = NULL;
 355     char *oldDownLevelHook = NULL;
 356     int   result = TCL_ERROR;
 357
 358     if (argc > 3) {
 359         Tcl_AppendResult (interp, tclXWrongArgs, argv[0],
 360                           " [prompt] [prompt2]", (char *) NULL);
 361         return TCL_ERROR;
 362     }
 363     if (argc > 1) {
 364         if (SetPromptVar (interp, "topLevelPromptHook", argv[1],
 365                           &oldTopLevelHook) != TCL_OK)
 366             goto exitPoint;
 367     }
 368     if (argc > 2) {
 369         if (SetPromptVar (interp, "downLevelPromptHook", argv[2],
 370                           &oldDownLevelHook) != TCL_OK)
 371             goto exitPoint;
 372     }
 373
 374     Tcl_CommandLoop (interp, stdin, stdout, tclShellCmdEvalProc, 0);
 375
 376     if (oldTopLevelHook != NULL)
 377         SetPromptVar (interp, "topLevelPromptHook", oldTopLevelHook, NULL);
 378     if (oldDownLevelHook != NULL)
 379         SetPromptVar (interp, "downLevelPromptHook", oldDownLevelHook, NULL);
 380
 381     result = TCL_OK;
 382 exitPoint:
 383     if (oldTopLevelHook != NULL)
 384         ckfree (oldTopLevelHook);
 385     if (oldDownLevelHook != NULL)
 386         ckfree (oldDownLevelHook);
 387     return result;
 388 }