ckMain.c

   1 /*
   2  * ckMain.c --
   3  *
   4  *      This file contains a generic main program for Ck-based applications.
   5  *      It can be used as-is for many applications, just by supplying a
   6  *      different appInitProc procedure for each specific application.
   7  *      Or, it can be used as a template for creating new main programs
   8  *      for applications.
   9  *
  10  * Copyright (c) 1990-1994 The Regents of the University of California.
  11  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  12  * Copyright (c) 1995 Christian Werner
  13  *
  14  * See the file "license.terms" for information on usage and redistribution
  15  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  16  */
  17
  18 #include "ckPort.h"
  19 #include "ck.h"
  20
  21 /*
  22  * Global variables used by the main program:
  23  */
  24
  25 static Tcl_Interp *interp;      /* Interpreter for this application. */
  26 static char *fileName = NULL;   /* Script to source, if any. */
  27
  28 #ifdef TCL_MEM_DEBUG
  29 static char dumpFile[100];      /* Records where to dump memory allocation
  30                                  * information. */
  31 static int quitFlag = 0;        /* 1 means the "checkmem" command was
  32                                  * invoked, so the application should quit
  33                                  * and dump memory allocation information. */
  34 static int      CheckmemCmd _ANSI_ARGS_((ClientData clientData,
  35                     Tcl_Interp *interp, int argc, char *argv[]));
  36 #endif
  37 \f
  38 /*
  39  *----------------------------------------------------------------------
  40  *
  41  * Ck_Main --
  42  *
  43  *      Main program for curses wish.
  44  *
  45  * Results:
  46  *      None. This procedure never returns (it exits the process when
  47  *      it's done.
  48  *
  49  * Side effects:
  50  *      This procedure initializes the toolkit and then starts
  51  *      interpreting commands;  almost anything could happen, depending
  52  *      on the script being interpreted.
  53  *
  54  *----------------------------------------------------------------------
  55  */
  56
  57 void
  58 Ck_Main(argc, argv, appInitProc)
  59     int argc;                           /* Number of arguments. */
  60     char **argv;                        /* Array of argument strings. */
  61     int (*appInitProc)();               /* Application-specific initialization
  62                                          * procedure to call after most
  63                                          * initialization but before starting
  64                                          * to execute commands. */
  65 {
  66     char *args, *msg, *argv0;
  67     char buf[20];
  68     int code;
  69 #if !((TCL_MAJOR_VERSION == 7) && (TCL_MINOR_VERSION <= 4))
  70     Tcl_Channel errChannel;
  71 #endif
  72
  73 #if !((TCL_MAJOR_VERSION == 7) && (TCL_MINOR_VERSION <= 4))
  74     Tcl_FindExecutable(argv[0]);
  75 #endif
  76
  77     interp = Tcl_CreateInterp();
  78
  79 #ifndef __WIN32__
  80     if (!isatty(0) || !isatty(1)) {
  81 #if (TCL_MAJOR_VERSION == 7) && (TCL_MINOR_VERSION <= 4)
  82         fprintf(stderr, "standard input/output must be terminal\n");
  83
  84 #else
  85         errChannel = Tcl_GetStdChannel(TCL_STDERR);
  86         if (errChannel)
  87             Tcl_Write(errChannel,
  88                 "standard input/output must be terminal\n", -1);
  89 #endif
  90         Tcl_Eval(interp, "exit 1");
  91 #if (TCL_MAJOR_VERSION >= 8)
  92         Tcl_Exit(1);
  93 #else
  94         exit(1);    /* Just in case */
  95 #endif
  96     }
  97 #endif
  98
  99 #ifdef TCL_MEM_DEBUG
 100     Tcl_InitMemory(interp);
 101     Tcl_InitMemory(interp);
 102     Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
 103             (Tcl_CmdDeleteProc *) NULL);
 104 #endif
 105
 106     /*
 107      * Parse command-line arguments. Argv[1] must contain the name
 108      * of the script file to process.
 109      */
 110
 111     argv0 = argv[0];
 112     if (argc > 1) {
 113         fileName = argv[1];
 114         argc--;
 115         argv++;
 116     }
 117
 118     /*
 119      * Make command-line arguments available in the Tcl variables "argc"
 120      * and "argv".
 121      */
 122
 123     args = Tcl_Merge(argc-1, argv+1);
 124     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
 125     ckfree(args);
 126     sprintf(buf, "%d", argc-1);
 127     Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
 128     Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv0,
 129         TCL_GLOBAL_ONLY);
 130     Tcl_SetVar(interp, "tcl_interactive", (fileName == NULL) ? "1" : "0",
 131         TCL_GLOBAL_ONLY);
 132
 133     /*
 134      * Invoke application-specific initialization.
 135      */
 136
 137     if ((*appInitProc)(interp) != TCL_OK) {
 138 #if (TCL_MAJOR_VERSION == 7) && (TCL_MINOR_VERSION <= 4)
 139         fprintf(stderr, "application-specific initialization failed: %s\n",
 140             interp->result);
 141 #else
 142         errChannel = Tcl_GetStdChannel(TCL_STDERR);
 143         if (errChannel) {
 144             Tcl_Write(errChannel,
 145                 "application-specific initialization failed: ", -1);
 146             Tcl_Write(errChannel, interp->result, -1);
 147             Tcl_Write(errChannel, "\n", 1);
 148         }
 149 #endif
 150         msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
 151         goto errorExit;
 152     }
 153
 154     /*
 155      * Invoke the script specified on the command line, if any.
 156      */
 157
 158     if (fileName != NULL) {
 159         code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL);
 160         if (code != TCL_OK)
 161             goto error;
 162         Tcl_ResetResult(interp);
 163         goto mainLoop;
 164     }
 165
 166     /*
 167      * We're running interactively.  Source a user-specific startup
 168      * file if the application specified one and if the file exists.
 169      */
 170
 171 #if (TCL_MAJOR_VERSION == 7) && (TCL_MINOR_VERSION <= 4)
 172     if (tcl_RcFileName != NULL) {
 173         Tcl_DString temp;
 174         char *fullName;
 175         FILE *f;
 176
 177         Tcl_DStringInit(&temp);
 178         fullName = Tcl_TildeSubst(interp, fileName, &temp);
 179         if (fullName == NULL)
 180             fprintf(stderr, "%s\n", interp->result);
 181         else {
 182
 183             /*
 184              * Test for the existence of the rc file before trying to read it.
 185              */
 186
 187             f = fopen(fullName, "r");
 188             if (f != NULL) {
 189                 fclose(f);
 190                 if (Tcl_EvalFile(interp, fullName) != TCL_OK)
 191                     fprintf(stderr, "%s\n", interp->result);
 192             }
 193             Tcl_DStringFree(&temp);
 194         }
 195     }
 196 #else
 197     fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
 198     if (fileName != NULL) {
 199         Tcl_Channel c;
 200         Tcl_DString temp;
 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             Tcl_DStringFree(&temp);
 229         }
 230     }
 231 #endif
 232
 233 mainLoop:
 234     /*
 235      * Loop infinitely, waiting for commands to execute.
 236      */
 237
 238 #ifdef TCL_MEM_DEBUG
 239     Tcl_Eval(interp, "proc exit {{code 0}} {destroy .}");
 240 #endif
 241
 242     Ck_MainLoop();
 243
 244 #ifdef TCL_MEM_DEBUG
 245     if (quitFlag) {
 246         Tcl_DeleteInterp(interp);
 247         Tcl_DumpActiveMemory(dumpFile);
 248     }
 249 #endif
 250
 251     /*
 252      * Invoke Tcl exit command.
 253      */
 254
 255     Tcl_Eval(interp, "exit");
 256 #if (TCL_MAJOR_VERSION >= 8)
 257     Tcl_Exit(1);
 258 #else
 259     exit(1);    /* Just in case */
 260 #endif
 261
 262 error:
 263     msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
 264     if (msg == NULL) {
 265         msg = interp->result;
 266     }
 267 errorExit:
 268     if (msg != NULL) {
 269 #if (TCL_MAJOR_VERSION == 7) && (TCL_MINOR_VERSION <= 4)
 270         fprintf(stderr, "%s\n", msg);
 271 #else
 272         errChannel = Tcl_GetStdChannel(TCL_STDERR);
 273         if (errChannel) {
 274             Tcl_Write(errChannel, msg, -1);
 275             Tcl_Write(errChannel, "\n", 1);
 276         }
 277 #endif
 278     }
 279     Tcl_Eval(interp, "exit 1");
 280 #if (TCL_MAJOR_VERSION >= 8)
 281     Tcl_Exit(1);
 282 #else
 283     exit(1);    /* Just in case */
 284 #endif
 285 }
 286 \f
 287 /*
 288  *----------------------------------------------------------------------
 289  *
 290  * CheckmemCmd --
 291  *
 292  *      This is the command procedure for the "checkmem" command, which
 293  *      causes the application to exit after printing information about
 294  *      memory usage to the file passed to this command as its first
 295  *      argument.
 296  *
 297  * Results:
 298  *      Returns a standard Tcl completion code.
 299  *
 300  * Side effects:
 301  *      None.
 302  *
 303  *----------------------------------------------------------------------
 304  */
 305 #ifdef TCL_MEM_DEBUG
 306
 307 static int
 308 CheckmemCmd(clientData, interp, argc, argv)
 309     ClientData clientData;              /* Not used. */
 310     Tcl_Interp *interp;                 /* Interpreter for evaluation. */
 311     int argc;                           /* Number of arguments. */
 312     char *argv[];                       /* String values of arguments. */
 313 {
 314     if (argc != 2) {
 315         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 316                 " fileName\"", (char *) NULL);
 317         return TCL_ERROR;
 318     }
 319     strcpy(dumpFile, argv[1]);
 320     quitFlag = 1;
 321     return TCL_OK;
 322 }
 323 #endif
 324