distrib/sources/api/tcl/loop.c

   1 /*      $LAAS: loop.c,v 1.11 2005/10/04 07:25:12 matthieu Exp $ */
   2
   3 /*
   4  * Copyright (c) 2001-2004 LAAS/CNRS                  --  Tue Oct 16 2001
   5  * All rights reserved.                                    Anthony Mallet
   6  *
   7  * Redistribution and use  in source  and binary  forms,  with or without
   8  * modification, are permitted provided that the following conditions are
   9  * met:
  10  *
  11  *   1. Redistributions of  source  code must retain the  above copyright
  12  *      notice, this list of conditions and the following disclaimer.
  13  *   2. Redistributions in binary form must reproduce the above copyright
  14  *      notice,  this list of  conditions and the following disclaimer in
  15  *      the  documentation  and/or  other   materials provided  with  the
  16  *      distribution.
  17  *
  18  * THIS  SOFTWARE IS PROVIDED BY  THE  COPYRIGHT HOLDERS AND CONTRIBUTORS
  19  * "AS IS" AND  ANY  EXPRESS OR IMPLIED  WARRANTIES,  INCLUDING,  BUT NOT
  20  * LIMITED TO, THE IMPLIED WARRANTIES  OF MERCHANTABILITY AND FITNESS FOR
  21  * A PARTICULAR  PURPOSE ARE DISCLAIMED. IN  NO EVENT SHALL THE COPYRIGHT
  22  * HOLDERS OR      CONTRIBUTORS  BE LIABLE FOR   ANY    DIRECT, INDIRECT,
  23  * INCIDENTAL,  SPECIAL,  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
  24  * BUT NOT LIMITED TO, PROCUREMENT OF  SUBSTITUTE GOODS OR SERVICES; LOSS
  25  * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
  26  * ON ANY THEORY OF LIABILITY, WHETHER IN  CONTRACT, STRICT LIABILITY, OR
  27  * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
  28  * USE   OF THIS SOFTWARE, EVEN   IF ADVISED OF   THE POSSIBILITY OF SUCH
  29  * DAMAGE.
  30  */
  31
  32 #include <stdio.h>
  33 #include <stdlib.h>
  34 #include <string.h>
  35 #include <unistd.h>
  36 #include <libgen.h>
  37 #include <setjmp.h>
  38 #include AVT_H
  39
  40 #include "eltclsh.h"
  41
  42 char           *avt_gettcldistpath();
  43
  44 static jmp_buf interactive_exit;
  45
  46 //static char   copyright[] = " - Copyright (C) 2001-2005 LAAS-CNRS";
  47 //static char  *version = ELTCLSH_VERSION;
  48
  49 avt_interactive_exit()
  50 {
  51     longjmp(interactive_exit, 1);
  52 }
  53
  54 /*
  55  * elTclshLoop ----------------------------------------------------------
  56  *
  57  * Main loop: it reads commands and execute them
  58  */
  59
  60 #if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 4
  61 void
  62 elTclshLoop(int argc, const char **argv, ElTclAppInitProc appInitProc)
  63 #else
  64 void
  65 elTclshLoop(int argc, char **argv, ElTclAppInitProc appInitProc)
  66 #endif                          /* TCL_VERSION */
  67 {
  68     ElTclInterpInfo *iinfo;
  69     HistEvent       ev;
  70
  71     Tcl_Obj        *resultPtr, *command;
  72
  73 #if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 4
  74     const char     *fileName, *args;
  75     const char     *eltclLibrary[2];
  76
  77 #else
  78     char           *fileName, *args;
  79     char           *eltclLibrary[2];
  80
  81 #endif                          /* TCL_VERSION */
  82     Tcl_DString     initFile;
  83     char            buffer[1000], *bytes;
  84     int             code, tty, length;
  85     int             exitCode = 0;
  86     int             command_exit;
  87     Tcl_Channel     inChannel, outChannel, errChannel;
  88
  89     /* create main data structure */
  90     iinfo = calloc(1, sizeof(*iinfo));
  91     if (iinfo == NULL) {
  92         fputs("cannot alloc %d bytes\n", stderr);
  93         return;
  94     }
  95
  96     /* initialize interpreter */
  97     iinfo->interp = Tcl_CreateInterp();
  98     if (iinfo->interp == NULL) {
  99         fputs("cannot create tcl interpreter\n", stderr);
 100         free(iinfo);
 101         return;
 102     }
 103
 104     /*
 105      * Make command-line arguments available in the Tcl variables "argc"
 106      * and "argv".  If the first argument doesn't start with a "-" then
 107      * strip it off and use it as the name of a script file to process.
 108      */
 109
 110     fileName = NULL;
 111     if ((argc > 1) && (argv[1][0] != '-')) {
 112         fileName = argv[1];
 113         argc--;
 114         argv++;
 115     }
 116     args = Tcl_Merge(argc - 1, argv + 1);
 117     Tcl_SetVar(iinfo->interp, "argv", args, TCL_GLOBAL_ONLY);
 118     Tcl_Free((char *) args);
 119     snprintf(buffer, sizeof(buffer), "%d", argc - 1);
 120     Tcl_SetVar(iinfo->interp, "argc", buffer, TCL_GLOBAL_ONLY);
 121     args = (fileName != NULL) ? fileName : argv[0];
 122     Tcl_SetVar(iinfo->interp, "argv0", args, TCL_GLOBAL_ONLY);
 123     iinfo->argv0 = basename((char *) args);
 124
 125
 126     /* Set the "tcl_interactive" variable. */
 127     tty = isatty(0);
 128     Tcl_SetVar(iinfo->interp, "tcl_interactive", ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
 129
 130     /* Invoke application-specific initialization. */
 131     if ((*appInitProc) (iinfo) != TCL_OK) {
 132         errChannel = Tcl_GetStdChannel(TCL_STDERR);
 133         if (errChannel) {
 134 #if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 4
 135             const char     *msg;
 136 #else
 137             char           *msg;
 138 #endif /* TCL_VERSION */
 139
 140             msg = Tcl_GetVar(iinfo->interp, "errorInfo", TCL_GLOBAL_ONLY);
 141             if (msg != NULL) {
 142                 Tcl_Write(errChannel, msg, strlen(msg));
 143                 Tcl_Write(errChannel, "\n", 1);
 144             }
 145             resultPtr = Tcl_GetObjResult(iinfo->interp);
 146             bytes = Tcl_GetStringFromObj(resultPtr, &length);
 147             Tcl_Write(errChannel, bytes, length);
 148             Tcl_Write(errChannel, "\n", 1);
 149         }
 150
 151         exitCode = 2;
 152         goto done;
 153     }
 154
 155     /* source standard eltclsh libraries */
 156     eltclLibrary[0] = avt_gettcldistpath();
 157     if (eltclLibrary[0] == NULL) {
 158         eltclLibrary[0] = ".";
 159     }
 160     eltclLibrary[1] = "el_init.tcl";
 161     Tcl_SetVar(iinfo->interp, "eltcl_library", eltclLibrary[0], TCL_GLOBAL_ONLY);
 162     Tcl_DStringInit(&initFile);
 163     if (Tcl_EvalFile(iinfo->interp, Tcl_JoinPath(2, eltclLibrary, &initFile)) != TCL_OK) {
 164         Tcl_AppendResult(iinfo->interp, "\nThe directory ", eltclLibrary[0], " does not contain a valid ", eltclLibrary[1], " file.\nPlease check your installation.\n", NULL);
 165         Tcl_DStringFree(&initFile);
 166
 167         errChannel = Tcl_GetStdChannel(TCL_STDERR);
 168         if (errChannel) {
 169             Tcl_AddErrorInfo(iinfo->interp, "");
 170             Tcl_Write(errChannel, Tcl_GetStringResult(iinfo->interp), -1);
 171         }
 172         exitCode = 2;
 173         goto done;
 174     }
 175     Tcl_DStringFree(&initFile);
 176
 177     (void) Tcl_SourceRCFile(iinfo->interp);
 178     Tcl_Flush(Tcl_GetStdChannel(TCL_STDERR));
 179
 180     avt_TrapSegV();
 181
 182     /* If a script file was specified then just source that file and quit. */
 183     if (fileName != NULL) {
 184         code = Tcl_EvalFile(iinfo->interp, fileName);
 185         if (code != TCL_OK) {
 186             errChannel = Tcl_GetStdChannel(TCL_STDERR);
 187             if (errChannel) {
 188                 /* The following statement guarantees that the errorInfo
 189                  * variable is set properly. */
 190                 Tcl_AddErrorInfo(iinfo->interp, "");
 191                 Tcl_Write(errChannel, Tcl_GetVar(iinfo->interp, "errorInfo", TCL_GLOBAL_ONLY), -1);
 192                 Tcl_Write(errChannel, "\n", 1);
 193             }
 194             exitCode = 1;
 195         }
 196
 197         goto done;
 198     }
 199
 200     /* Print the copyright message in interactive mode */
 201     if (tty) {
 202         avt_banner("AvtShell", "Timing & Signal Integrity Analysis Platform", "2000");
 203     }
 204
 205     /*
 206      * Process commands from stdin until there's an end-of-file. Note
 207      * that we need to fetch the standard channels again after every
 208      * eval, since they may have been changed.
 209      */
 210
 211     iinfo->command = Tcl_NewObj();
 212     Tcl_IncrRefCount(iinfo->command);
 213
 214     inChannel = Tcl_GetStdChannel(TCL_STDIN);
 215     outChannel = Tcl_GetStdChannel(TCL_STDOUT);
 216     iinfo->gotPartial = 0;
 217
 218     for (; /* eternity */ ;) {
 219
 220         if (tty) {
 221             const char     *line;
 222
 223             line = el_gets(iinfo->el, &length);
 224             if (line == NULL) goto done;
 225
 226             command = Tcl_NewStringObj(line, length);
 227             Tcl_AppendObjToObj(iinfo->command, command);
 228         }
 229         else {
 230             /* using libedit but not a tty - must use gets */
 231             if (!inChannel) goto done;
 232
 233             length = Tcl_GetsObj(inChannel, iinfo->command);
 234             if (length < 0) goto done;
 235             if ((length == 0) && Tcl_Eof(inChannel) && (!iinfo->gotPartial)) goto done;
 236
 237             /* Add the newline back to the string */
 238             Tcl_AppendToObj(iinfo->command, "\n", 1);
 239         }
 240
 241         if (!Tcl_CommandComplete(Tcl_GetStringFromObj(iinfo->command, &length))) {
 242             iinfo->gotPartial = 1;
 243             continue;
 244         }
 245
 246         if (tty && length > 1) {
 247             /* add the command line to history */
 248             history(iinfo->history, &ev, H_ENTER, Tcl_GetStringFromObj(iinfo->command, NULL));
 249         }
 250
 251         /* tricky: if the command calls el::get[sc], the completion engine
 252          * will think that iinfo->command is the beginning of an incomplete
 253          * command. Thus we must reset it before the Tcl_Eval call... */
 254         command = iinfo->command;
 255
 256         iinfo->command = Tcl_NewObj();
 257         Tcl_IncrRefCount(iinfo->command);
 258
 259         iinfo->gotPartial = 0;
 260
 261         command_exit = 0;
 262         if (tty) {
 263             if (setjmp(interactive_exit) == 0) {
 264                 MBK_EXIT_FUNCTION = avt_interactive_exit;
 265                 code = Tcl_EvalObj(iinfo->interp, command);
 266             }
 267             else {
 268                 command_exit = 1;
 269             }
 270         }
 271         else code = Tcl_EvalObj(iinfo->interp, command);
 272
 273         Tcl_DecrRefCount(command);
 274
 275         inChannel = Tcl_GetStdChannel(TCL_STDIN);
 276         outChannel = Tcl_GetStdChannel(TCL_STDOUT);
 277         errChannel = Tcl_GetStdChannel(TCL_STDERR);
 278         if (code != TCL_OK) {
 279             if (errChannel) {
 280                 resultPtr = Tcl_GetObjResult(iinfo->interp);
 281                 bytes = Tcl_GetStringFromObj(resultPtr, &length);
 282                 Tcl_Write(errChannel, bytes, length);
 283                 Tcl_Write(errChannel, "\n", 1);
 284             }
 285         }
 286         else if (tty) {
 287             resultPtr = Tcl_GetObjResult(iinfo->interp);
 288             bytes = Tcl_GetStringFromObj(resultPtr, &length);
 289
 290             if ((length > 0) && outChannel) {
 291                 Tcl_Write(outChannel, bytes, length);
 292                 Tcl_Write(outChannel, "\n", 1);
 293             }
 294         }
 295         if (command_exit) Tcl_Write(outChannel, "PROCEED WITH CAUTION\n", 21);
 296     }
 297
 298     /*
 299      * Rather than calling exit, invoke the "exit" command so that
 300      * users can replace "exit" with some other command to do additional
 301      * cleanup on exit.  The Tcl_Eval call should never return.
 302      */
 303
 304 done:
 305     if (iinfo->command != NULL) Tcl_DecrRefCount(iinfo->command);
 306     snprintf(buffer, sizeof(buffer), "exit %d", exitCode);
 307     Tcl_Eval(iinfo->interp, buffer);
 308 }
 309
 310
 311 /*
 312  * elTclExit ------------------------------------------------------------
 313  *
 314  * Destroy global info structure
 315  */
 316
 317 int
 318 elTclExit(ClientData data,
 319           Tcl_Interp * interp, int objc, Tcl_Obj * const objv[])
 320 {
 321     ElTclInterpInfo *iinfo = data;
 322     int             value;
 323
 324     if ((objc != 1) && (objc != 2)) {
 325         Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
 326         return TCL_ERROR;
 327     }
 328
 329     if (objc == 1) {
 330         value = 0;
 331     }
 332     else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
 333         return TCL_ERROR;
 334     }
 335
 336     el_end(iinfo->el);
 337     history_end(iinfo->history);
 338     history_end(iinfo->askaHistory);
 339
 340     elTclHandlersExit(iinfo);
 341     Tcl_DecrRefCount(iinfo->prompt1Name);
 342     Tcl_DecrRefCount(iinfo->prompt2Name);
 343     Tcl_DecrRefCount(iinfo->matchesName);
 344     free(iinfo);
 345
 346     fputs("\n", stdout);
 347     Tcl_Exit(value);
 348     return TCL_OK;
 349 }