cvs.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_Interp *, char *, int, char**) = 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 (Tcl_Interp *interp, char *command)
  71 {
  72     char  *nextPtr;
  73
  74     if ((!STRNEQU (command, "set", 3)) || (!isspace (command [3])))
  75         return FALSE;  /* Quick check */
  76
  77     nextPtr = TclWordEnd (command, FALSE);
  78     if (*nextPtr == '\0')
  79         return FALSE;
  80     nextPtr = TclWordEnd (nextPtr, FALSE);
  81     if (*nextPtr == '\0')
  82         return FALSE;
  83
  84     while (*nextPtr != '\0') {
  85         if (!isspace (*nextPtr))
  86             return TRUE;
  87         nextPtr++;
  88     }
  89     return FALSE;
  90 }
  91 \f
  92 /*
  93  *-----------------------------------------------------------------------------
  94  *
  95  * OutFlush --
  96  *
  97  *   Flush a stdio file and check for errors.
  98  *
  99  *-----------------------------------------------------------------------------
 100  */
 101 static void
 102 OutFlush (FILE *filePtr)
 103 {
 104     int stat;
 105
 106     stat = fflush (filePtr);
 107     if (ferror (filePtr)) {
 108         if (errno != EINTR)
 109             panic ("command loop: error writing to output file: %s\n",
 110                    strerror (errno));
 111         clearerr (filePtr);
 112     }
 113 }
 114 \f
 115 /*
 116  *-----------------------------------------------------------------------------
 117  *
 118  * Tcl_PrintResult --
 119  *
 120  *      Print a Tcl result
 121  *
 122  * Results:
 123  *
 124  *      Takes an open file pointer, a return value and some result
 125  *      text.  Prints the result text if the return value is TCL_OK,
 126  *      prints "Error:" and the result text if it's TCL_ERROR,
 127  *      else prints "Bad return code:" and the result text.
 128  *
 129  *-----------------------------------------------------------------------------
 130  */
 131 static void
 132 Tcl_PrintResult (FILE *fp, int returnval, char *resultText)
 133 {
 134
 135     if (returnval == TCL_OK) {
 136         if (resultText [0] != '\0') {
 137             fputs (resultText, fp);
 138             fputs ("\n", fp);
 139         }
 140     } else {
 141         OutFlush (fp);
 142         fputs ((returnval == TCL_ERROR) ? "Error" : "Bad return code", stderr);
 143         fputs (": ", stderr);
 144         fputs (resultText, stderr);
 145         fputs ("\n", stderr);
 146         OutFlush (stderr);
 147     }
 148 }
 149 \f
 150 /*
 151  *-----------------------------------------------------------------------------
 152  *
 153  * OutputPromp --
 154  *     Outputs a prompt by executing either the command string in
 155  *     TCLENV(topLevelPromptHook) or TCLENV(downLevelPromptHook).
 156  *
 157  *-----------------------------------------------------------------------------
 158  */
 159 static void
 160 OutputPrompt (Tcl_Interp *interp, FILE *outFP, int topLevel)
 161 {
 162     char *hookName;
 163     char *promptHook;
 164     int   result;
 165     int   promptDone = FALSE;
 166
 167     hookName = topLevel ? "topLevelPromptHook"
 168                         : "downLevelPromptHook";
 169
 170     promptHook = Tcl_GetVar2 (interp, "TCLENV", hookName, 1);
 171     if ((promptHook != NULL) && (promptHook [0] != '\0')) {
 172         result = Tcl_Eval (interp, promptHook, 0, (char **)NULL);
 173         if (!((result == TCL_OK) || (result == TCL_RETURN))) {
 174             fputs ("Error in prompt hook: ", stderr);
 175             fputs (interp->result, stderr);
 176             fputs ("\n", stderr);
 177             Tcl_PrintResult (outFP, result, interp->result);
 178         } else {
 179             fputs (interp->result, outFP);
 180             promptDone = TRUE;
 181         }
 182     }
 183     if (!promptDone) {
 184         if (topLevel)
 185             fputs ("%", outFP);
 186         else
 187             fputs (">", outFP);
 188     }
 189     OutFlush (outFP);
 190
 191 }
 192 \f
 193 /*
 194  *-----------------------------------------------------------------------------
 195  *
 196  * Tcl_CommandLoop --
 197  *
 198  *   Run a Tcl command loop.  The command loop interactively prompts for,
 199  * reads and executes commands. Two entries in the global array TCLENV
 200  * contain prompt hooks.  A prompt hook is Tcl code that is executed and
 201  * its result is used as the prompt string.  The element `topLevelPromptHook'
 202  * is the hook that generates the main prompt.  The element
 203  * `downLevelPromptHook' is the hook to generate the prompt for reading
 204  * continuation lines for incomplete commands.  If a signal occurs while
 205  * in the command loop, it is reset and ignored.  EOF terminates the loop.
 206  *
 207  * Parameters:
 208  *   o interp (I) - A pointer to the interpreter
 209  *   o inFile (I) - The file to read commands from.
 210  *   o outFile (I) - The file to write the prompts to.
 211  *   o evalProc (I) - The function to call to evaluate a command.
 212  *     Should be either Tcl_Eval or Tcl_RecordAndEval if history is desired.
 213  *   o options (I) - Currently unused.
 214  *-----------------------------------------------------------------------------
 215  */
 216 void
 217 Tcl_CommandLoop (Tcl_Interp *interp, FILE *inFile, FILE *outFile, int (*evalProc)(Tcl_Interp *, char *, int, char**), unsigned options)
 218 {
 219     Tcl_CmdBuf cmdBuf;
 220     char       inputBuf[256];
 221     int        topLevel = TRUE;
 222     int        result;
 223     char      *cmd;
 224
 225     cmdBuf = Tcl_CreateCmdBuf();
 226
 227     while (TRUE) {
 228         /*
 229          * If a signal came in, process it and drop any pending command.
 230          */
 231         if (tclReceivedSignal) {
 232             Tcl_CheckForSignal (interp, TCL_OK);
 233             Tcl_DeleteCmdBuf(cmdBuf);
 234             cmdBuf = Tcl_CreateCmdBuf();
 235             topLevel = TRUE;
 236         }
 237         /*
 238          * Output a prompt and input a command.
 239          */
 240         clearerr (inFile);
 241         clearerr (outFile);
 242         OutputPrompt (interp, outFile, topLevel);
 243         errno = 0;
 244         if (fgets (inputBuf, sizeof (inputBuf), inFile) == NULL) {
 245             if (!feof(inFile) && (errno == EINTR)) {
 246                 putchar('\n');
 247                 continue;  /* Next command */
 248             }
 249             if (ferror (inFile))
 250                 panic ("command loop: error on input file: %s\n",
 251                        strerror (errno));
 252             goto endOfFile;
 253         }
 254         cmd = Tcl_AssembleCmd(cmdBuf, inputBuf);
 255
 256         if (cmd == NULL) {
 257             topLevel = FALSE;
 258             continue;  /* Next line */
 259         }
 260         /*
 261          * Finally have a complete command, go eval it and maybe output the
 262          * result.
 263          */
 264         result = (*evalProc) (interp, cmd, 0, (char **)NULL);
 265         if (result != TCL_OK || !IsSetVarCmd (interp, cmd))
 266             Tcl_PrintResult (outFile, result, interp->result);
 267         topLevel = TRUE;
 268     }
 269 endOfFile:
 270     Tcl_DeleteCmdBuf(cmdBuf);
 271 }
 272 \f
 273 /*
 274  *-----------------------------------------------------------------------------
 275  *
 276  * SetPromptVar --
 277  *     Set one of the prompt hook variables, saving a copy of the old
 278  *     value, if it exists.
 279  *
 280  * Parameters:
 281  *   o hookVarName (I) - The name of the prompt hook, which is an element
 282  *     of the TCLENV array.  One of topLevelPromptHook or downLevelPromptHook.
 283  *   o newHookValue (I) - The new value for the prompt hook.
 284  *   o oldHookValuePtr (O) - If not NULL, then a pointer to a copy of the
 285  *     old prompt value is returned here.  NULL is returned if there was not
 286  *     old value.  This is a pointer to a malloc-ed string that must be
 287  *     freed when no longer needed.
 288  * Result:
 289  *   TCL_OK if the hook variable was set ok, TCL_ERROR if an error occured.
 290  *-----------------------------------------------------------------------------
 291  */
 292 static int
 293 SetPromptVar (Tcl_Interp *interp, char *hookVarName, char *newHookValue, char **oldHookValuePtr)
 294 {
 295     char *hookValue;
 296     char *oldHookPtr = NULL;
 297
 298     if (oldHookValuePtr != NULL) {
 299         hookValue = Tcl_GetVar2 (interp, "TCLENV", hookVarName,
 300                                  TCL_GLOBAL_ONLY);
 301         if (hookValue != NULL) {
 302             oldHookPtr = ckalloc (strlen (hookValue) + 1);
 303             strcpy (oldHookPtr, hookValue);
 304         }
 305     }
 306     if (Tcl_SetVar2 (interp, "TCLENV", hookVarName, newHookValue,
 307                      TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
 308         if (oldHookPtr != NULL)
 309             ckfree (oldHookPtr);
 310         return TCL_ERROR;
 311     }
 312     if (oldHookValuePtr != NULL)
 313         *oldHookValuePtr = oldHookPtr;
 314     return TCL_OK;
 315 }
 316 \f
 317 /*
 318  *-----------------------------------------------------------------------------
 319  *
 320  * Tcl_CommandloopCmd --
 321  *     Implements the TCL commandloop command:
 322  *       commandloop prompt prompt2
 323  *
 324  * Results:
 325  *     Standard TCL results.
 326  *
 327  *-----------------------------------------------------------------------------
 328  */
 329 int
 330 Tcl_CommandloopCmd(
 331     ClientData  clientData,
 332     Tcl_Interp *interp,
 333     int         argc,
 334     char      **argv
 335 )
 336 {
 337     char *oldTopLevelHook  = NULL;
 338     char *oldDownLevelHook = NULL;
 339     int   result = TCL_ERROR;
 340
 341     if (argc > 3) {
 342         Tcl_AppendResult (interp, tclXWrongArgs, argv[0],
 343                           " [prompt] [prompt2]", (char *) NULL);
 344         return TCL_ERROR;
 345     }
 346     if (argc > 1) {
 347         if (SetPromptVar (interp, "topLevelPromptHook", argv[1],
 348                           &oldTopLevelHook) != TCL_OK)
 349             goto exitPoint;
 350     }
 351     if (argc > 2) {
 352         if (SetPromptVar (interp, "downLevelPromptHook", argv[2],
 353                           &oldDownLevelHook) != TCL_OK)
 354             goto exitPoint;
 355     }
 356
 357     Tcl_CommandLoop (interp, stdin, stdout, tclShellCmdEvalProc, 0);
 358
 359     if (oldTopLevelHook != NULL)
 360         SetPromptVar (interp, "topLevelPromptHook", oldTopLevelHook, NULL);
 361     if (oldDownLevelHook != NULL)
 362         SetPromptVar (interp, "downLevelPromptHook", oldDownLevelHook, NULL);
 363
 364     result = TCL_OK;
 365 exitPoint:
 366     if (oldTopLevelHook != NULL)
 367         ckfree (oldTopLevelHook);
 368     if (oldDownLevelHook != NULL)
 369         ckfree (oldDownLevelHook);
 370     return result;
 371 }