cde/programs/dtdocbook/tcl/tclMain.c

   1 /*
   2  * CDE - Common Desktop Environment
   3  *
   4  * Copyright (c) 1993-2012, The Open Group. All rights reserved.
   5  *
   6  * These libraries and programs are free software; you can
   7  * redistribute them and/or modify them under the terms of the GNU
   8  * Lesser General Public License as published by the Free Software
   9  * Foundation; either version 2 of the License, or (at your option)
  10  * any later version.
  11  *
  12  * These libraries and programs are distributed in the hope that
  13  * they will be useful, but WITHOUT ANY WARRANTY; without even the
  14  * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  15  * PURPOSE. See the GNU Lesser General Public License for more
  16  * details.
  17  *
  18  * You should have received a copy of the GNU Lesser General Public
  19  * License along with these librararies and programs; if not, write
  20  * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  21  * Floor, Boston, MA 02110-1301 USA
  22  */
  23 /* $XConsortium: tclMain.c /main/2 1996/08/08 14:45:29 cde-hp $ */
  24 /*
  25  * tclMain.c --
  26  *
  27  *      Main program for Tcl shells and other Tcl-based applications.
  28  *
  29  * Copyright (c) 1988-1994 The Regents of the University of California.
  30  * Copyright (c) 1994-1996 Sun Microsystems, Inc.
  31  *
  32  * See the file "license.terms" for information on usage and redistribution
  33  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  34  *
  35  * SCCS: @(#) tclMain.c 1.50 96/04/10 16:40:57
  36  */
  37
  38 #include "tcl.h"
  39 #include "tclInt.h"
  40
  41 /*
  42  * The following code ensures that tclLink.c is linked whenever
  43  * Tcl is linked.  Without this code there's no reference to the
  44  * code in that file from anywhere in Tcl, so it may not be
  45  * linked into the application.
  46  */
  47
  48 EXTERN int Tcl_LinkVar();
  49 int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;
  50
  51 /*
  52  * Declarations for various library procedures and variables (don't want
  53  * to include tclPort.h here, because people might copy this file out of
  54  * the Tcl source directory to make their own modified versions).
  55  * Note:  "exit" should really be declared here, but there's no way to
  56  * declare it without causing conflicts with other definitions elsewher
  57  * on some systems, so it's better just to leave it out.
  58  */
  59
  60 extern int              isatty _ANSI_ARGS_((int fd));
  61 extern char *           strcpy _ANSI_ARGS_((char *dst, CONST char *src));
  62
  63 static Tcl_Interp *interp;      /* Interpreter for application. */
  64 static Tcl_DString command;     /* Used to buffer incomplete commands being
  65                                  * read from stdin. */
  66 #ifdef TCL_MEM_DEBUG
  67 static char dumpFile[100];      /* Records where to dump memory allocation
  68                                  * information. */
  69 static int quitFlag = 0;        /* 1 means the "checkmem" command was
  70                                  * invoked, so the application should quit
  71                                  * and dump memory allocation information. */
  72 #endif
  73
  74 /*
  75  * Forward references for procedures defined later in this file:
  76  */
  77
  78 #ifdef TCL_MEM_DEBUG
  79 static int              CheckmemCmd _ANSI_ARGS_((ClientData clientData,
  80                             Tcl_Interp *interp, int argc, char *argv[]));
  81 #endif
  82 \f
  83 /*
  84  *----------------------------------------------------------------------
  85  *
  86  * Tcl_Main --
  87  *
  88  *      Main program for tclsh and most other Tcl-based applications.
  89  *
  90  * Results:
  91  *      None. This procedure never returns (it exits the process when
  92  *      it's done.
  93  *
  94  * Side effects:
  95  *      This procedure initializes the Tk world and then starts
  96  *      interpreting commands;  almost anything could happen, depending
  97  *      on the script being interpreted.
  98  *
  99  *----------------------------------------------------------------------
 100  */
 101
 102 void
 103 Tcl_Main(argc, argv, appInitProc)
 104     int argc;                           /* Number of arguments. */
 105     char **argv;                        /* Array of argument strings. */
 106     Tcl_AppInitProc *appInitProc;       /* Application-specific initialization
 107                                          * procedure to call after most
 108                                          * initialization but before starting
 109                                          * to execute commands. */
 110 {
 111     char buffer[1000], *cmd, *args, *fileName;
 112     int code, gotPartial, tty, length;
 113     int exitCode = 0;
 114     Tcl_Channel inChannel, outChannel, errChannel;
 115     Tcl_DString temp;
 116
 117     Tcl_FindExecutable(argv[0]);
 118     interp = Tcl_CreateInterp();
 119 #ifdef TCL_MEM_DEBUG
 120     Tcl_InitMemory(interp);
 121     Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
 122             (Tcl_CmdDeleteProc *) NULL);
 123 #endif
 124
 125     /*
 126      * Make command-line arguments available in the Tcl variables "argc"
 127      * and "argv".  If the first argument doesn't start with a "-" then
 128      * strip it off and use it as the name of a script file to process.
 129      */
 130
 131     fileName = NULL;
 132     if ((argc > 1) && (argv[1][0] != '-')) {
 133         fileName = argv[1];
 134         argc--;
 135         argv++;
 136     }
 137     args = Tcl_Merge(argc-1, argv+1);
 138     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
 139     ckfree(args);
 140     sprintf(buffer, "%d", argc-1);
 141     Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
 142     Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
 143             TCL_GLOBAL_ONLY);
 144
 145     /*
 146      * Set the "tcl_interactive" variable.
 147      */
 148
 149     tty = isatty(0);
 150     Tcl_SetVar(interp, "tcl_interactive",
 151             ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
 152
 153     /*
 154      * Invoke application-specific initialization.
 155      */
 156
 157     if ((*appInitProc)(interp) != TCL_OK) {
 158         errChannel = Tcl_GetStdChannel(TCL_STDERR);
 159         if (errChannel) {
 160             Tcl_Write(errChannel,
 161                     "application-specific initialization failed: ", -1);
 162             Tcl_Write(errChannel, interp->result, -1);
 163             Tcl_Write(errChannel, "\n", 1);
 164         }
 165     }
 166
 167     /*
 168      * If a script file was specified then just source that file
 169      * and quit.
 170      */
 171
 172     if (fileName != NULL) {
 173         code = Tcl_EvalFile(interp, fileName);
 174         if (code != TCL_OK) {
 175             errChannel = Tcl_GetStdChannel(TCL_STDERR);
 176             if (errChannel) {
 177                 /*
 178                  * The following statement guarantees that the errorInfo
 179                  * variable is set properly.
 180                  */
 181
 182                 Tcl_AddErrorInfo(interp, "");
 183                 Tcl_Write(errChannel,
 184                         Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1);
 185                 Tcl_Write(errChannel, "\n", 1);
 186             }
 187             exitCode = 1;
 188         }
 189         goto done;
 190     }
 191
 192     /*
 193      * We're running interactively.  Source a user-specific startup
 194      * file if the application specified one and if the file exists.
 195      */
 196
 197     fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
 198
 199     if (fileName != NULL) {
 200         Tcl_Channel c;
 201         char *fullName;
 202
 203         Tcl_DStringInit(&temp);
 204         fullName = Tcl_TranslateFileName(interp, fileName, &temp);
 205         if (fullName == NULL) {
 206             errChannel = Tcl_GetStdChannel(TCL_STDERR);
 207             if (errChannel) {
 208                 Tcl_Write(errChannel, interp->result, -1);
 209                 Tcl_Write(errChannel, "\n", 1);
 210             }
 211         } else {
 212
 213             /*
 214              * Test for the existence of the rc file before trying to read it.
 215              */
 216
 217             c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
 218             if (c != (Tcl_Channel) NULL) {
 219                 Tcl_Close(NULL, c);
 220                 if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
 221                     errChannel = Tcl_GetStdChannel(TCL_STDERR);
 222                     if (errChannel) {
 223                         Tcl_Write(errChannel, interp->result, -1);
 224                         Tcl_Write(errChannel, "\n", 1);
 225                     }
 226                 }
 227             }
 228         }
 229         Tcl_DStringFree(&temp);
 230     }
 231
 232     /*
 233      * Process commands from stdin until there's an end-of-file.  Note
 234      * that we need to fetch the standard channels again after every
 235      * eval, since they may have been changed.
 236      */
 237
 238     gotPartial = 0;
 239     Tcl_DStringInit(&command);
 240     inChannel = Tcl_GetStdChannel(TCL_STDIN);
 241     outChannel = Tcl_GetStdChannel(TCL_STDOUT);
 242     while (1) {
 243         if (tty) {
 244             char *promptCmd;
 245
 246             promptCmd = Tcl_GetVar(interp,
 247                 gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
 248             if (promptCmd == NULL) {
 249 defaultPrompt:
 250                 if (!gotPartial && outChannel) {
 251                     Tcl_Write(outChannel, "% ", 2);
 252                 }
 253             } else {
 254                 code = Tcl_Eval(interp, promptCmd);
 255                 inChannel = Tcl_GetStdChannel(TCL_STDIN);
 256                 outChannel = Tcl_GetStdChannel(TCL_STDOUT);
 257                 errChannel = Tcl_GetStdChannel(TCL_STDERR);
 258                 if (code != TCL_OK) {
 259                     if (errChannel) {
 260                         Tcl_Write(errChannel, interp->result, -1);
 261                         Tcl_Write(errChannel, "\n", 1);
 262                     }
 263                     Tcl_AddErrorInfo(interp,
 264                             "\n    (script that generates prompt)");
 265                     goto defaultPrompt;
 266                 }
 267             }
 268             if (outChannel) {
 269                 Tcl_Flush(outChannel);
 270             }
 271         }
 272         if (!inChannel) {
 273             goto done;
 274         }
 275         length = Tcl_Gets(inChannel, &command);
 276         if (length < 0) {
 277             goto done;
 278         }
 279         if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
 280             goto done;
 281         }
 282
 283         /*
 284          * Add the newline removed by Tcl_Gets back to the string.
 285          */
 286
 287         (void) Tcl_DStringAppend(&command, "\n", -1);
 288
 289         cmd = Tcl_DStringValue(&command);
 290         if (!Tcl_CommandComplete(cmd)) {
 291             gotPartial = 1;
 292             continue;
 293         }
 294
 295         gotPartial = 0;
 296         code = Tcl_RecordAndEval(interp, cmd, 0);
 297         inChannel = Tcl_GetStdChannel(TCL_STDIN);
 298         outChannel = Tcl_GetStdChannel(TCL_STDOUT);
 299         errChannel = Tcl_GetStdChannel(TCL_STDERR);
 300         Tcl_DStringFree(&command);
 301         if (code != TCL_OK) {
 302             if (errChannel) {
 303                 Tcl_Write(errChannel, interp->result, -1);
 304                 Tcl_Write(errChannel, "\n", 1);
 305             }
 306         } else if (tty && (*interp->result != 0)) {
 307             if (outChannel) {
 308                 Tcl_Write(outChannel, interp->result, -1);
 309                 Tcl_Write(outChannel, "\n", 1);
 310             }
 311         }
 312 #ifdef TCL_MEM_DEBUG
 313         if (quitFlag) {
 314             Tcl_DeleteInterp(interp);
 315             Tcl_Exit(0);
 316         }
 317 #endif
 318     }
 319
 320     /*
 321      * Rather than calling exit, invoke the "exit" command so that
 322      * users can replace "exit" with some other command to do additional
 323      * cleanup on exit.  The Tcl_Eval call should never return.
 324      */
 325
 326 done:
 327     sprintf(buffer, "exit %d", exitCode);
 328     Tcl_Eval(interp, buffer);
 329 }
 330 \f
 331 /*
 332  *----------------------------------------------------------------------
 333  *
 334  * CheckmemCmd --
 335  *
 336  *      This is the command procedure for the "checkmem" command, which
 337  *      causes the application to exit after printing information about
 338  *      memory usage to the file passed to this command as its first
 339  *      argument.
 340  *
 341  * Results:
 342  *      Returns a standard Tcl completion code.
 343  *
 344  * Side effects:
 345  *      None.
 346  *
 347  *----------------------------------------------------------------------
 348  */
 349 #ifdef TCL_MEM_DEBUG
 350
 351         /* ARGSUSED */
 352 static int
 353 CheckmemCmd(clientData, interp, argc, argv)
 354     ClientData clientData;              /* Not used. */
 355     Tcl_Interp *interp;                 /* Interpreter for evaluation. */
 356     int argc;                           /* Number of arguments. */
 357     char *argv[];                       /* String values of arguments. */
 358 {
 359     extern char *tclMemDumpFileName;
 360     if (argc != 2) {
 361         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 362                 " fileName\"", (char *) NULL);
 363         return TCL_ERROR;
 364     }
 365     strcpy(dumpFile, argv[1]);
 366     tclMemDumpFileName = dumpFile;
 367     quitFlag = 1;
 368     return TCL_OK;
 369 }
 370 #endif