/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclmain.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclmain.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 64 by dashley, Sun Oct 30 04:21:11 2016 UTC revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
1  /*$Header$ */  /* $Header$ */
2  /*  /*
3   * tclMain.c --   * tclMain.c --
4   *   *
5   *      Main program for Tcl shells and other Tcl-based applications.   *      Main program for Tcl shells and other Tcl-based applications.
6   *   *
7   * Copyright (c) 1988-1994 The Regents of the University of California.   * Copyright (c) 1988-1994 The Regents of the University of California.
8   * Copyright (c) 1994-1997 Sun Microsystems, Inc.   * Copyright (c) 1994-1997 Sun Microsystems, Inc.
9   *   *
10   * See the file "license.terms" for information on usage and redistribution   * See the file "license.terms" for information on usage and redistribution
11   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12   *   *
13   * RCS: @(#) $Id: tclmain.c,v 1.2 2001/10/07 01:32:29 dtashley Exp $   * RCS: @(#) $Id: tclmain.c,v 1.2 2001/10/07 01:32:29 dtashley Exp $
14   */   */
15    
16  #define MODULE_TCLMAIN  #define MODULE_TCLMAIN
17    
18  #include "tclmain.h"  #include "tclmain.h"
19    
20  #include "tcl.h"  #include "tcl.h"
21  #include "tclInt.h"  #include "tclInt.h"
22    
23  #include "build_config.h"  #include "build_config.h"
24  #include "extninit.h"  #include "extninit.h"
25  #include "msgstrs.h"  #include "msgstrs.h"
26    
27    
28  # undef TCL_STORAGE_CLASS  # undef TCL_STORAGE_CLASS
29  # define TCL_STORAGE_CLASS DLLEXPORT  # define TCL_STORAGE_CLASS DLLEXPORT
30    
31  /*  /*
32   * The following code ensures that tclLink.c is linked whenever   * The following code ensures that tclLink.c is linked whenever
33   * Tcl is linked.  Without this code there's no reference to the   * Tcl is linked.  Without this code there's no reference to the
34   * code in that file from anywhere in Tcl, so it may not be   * code in that file from anywhere in Tcl, so it may not be
35   * linked into the application.   * linked into the application.
36   */   */
37    
38  EXTERN int Tcl_LinkVar();  EXTERN int Tcl_LinkVar();
39  int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;  int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;
40    
41  /*  /*
42   * Declarations for various library procedures and variables (don't want   * Declarations for various library procedures and variables (don't want
43   * to include tclPort.h here, because people might copy this file out of   * to include tclPort.h here, because people might copy this file out of
44   * the Tcl source directory to make their own modified versions).   * the Tcl source directory to make their own modified versions).
45   * Note:  "exit" should really be declared here, but there's no way to   * Note:  "exit" should really be declared here, but there's no way to
46   * declare it without causing conflicts with other definitions elsewher   * declare it without causing conflicts with other definitions elsewher
47   * on some systems, so it's better just to leave it out.   * on some systems, so it's better just to leave it out.
48   */   */
49    
50  extern int              isatty _ANSI_ARGS_((int fd));  extern int              isatty _ANSI_ARGS_((int fd));
51  extern char *           strcpy _ANSI_ARGS_((char *dst, CONST char *src));  extern char *           strcpy _ANSI_ARGS_((char *dst, CONST char *src));
52    
53  static char *tclStartupScriptFileName = NULL;  static char *tclStartupScriptFileName = NULL;
54    
55    
56    
57    
58  /*  /*
59   *----------------------------------------------------------------------   *----------------------------------------------------------------------
60   *   *
61   * TclSetStartupScriptFileName --   * TclSetStartupScriptFileName --
62   *   *
63   *      Primes the startup script file name, used to override the   *      Primes the startup script file name, used to override the
64   *      command line processing.   *      command line processing.
65   *   *
66   * Results:   * Results:
67   *      None.   *      None.
68   *   *
69   * Side effects:   * Side effects:
70   *      This procedure initializes the file name of the Tcl script to   *      This procedure initializes the file name of the Tcl script to
71   *      run at startup.   *      run at startup.
72   *   *
73   *----------------------------------------------------------------------   *----------------------------------------------------------------------
74   */   */
75  void TclSetStartupScriptFileName(fileName)  void TclSetStartupScriptFileName(fileName)
76      char *fileName;      char *fileName;
77  {  {
78      tclStartupScriptFileName = fileName;      tclStartupScriptFileName = fileName;
79  }  }
80    
81    
82  /*  /*
83   *----------------------------------------------------------------------   *----------------------------------------------------------------------
84   *   *
85   * TclGetStartupScriptFileName --   * TclGetStartupScriptFileName --
86   *   *
87   *      Gets the startup script file name, used to override the   *      Gets the startup script file name, used to override the
88   *      command line processing.   *      command line processing.
89   *   *
90   * Results:   * Results:
91   *      The startup script file name, NULL if none has been set.   *      The startup script file name, NULL if none has been set.
92   *   *
93   * Side effects:   * Side effects:
94   *      None.   *      None.
95   *   *
96   *----------------------------------------------------------------------   *----------------------------------------------------------------------
97   */   */
98  char *TclGetStartupScriptFileName()  char *TclGetStartupScriptFileName()
99  {  {
100      return tclStartupScriptFileName;      return tclStartupScriptFileName;
101  }  }
102    
103    
104    
105  /*  /*
106   *----------------------------------------------------------------------   *----------------------------------------------------------------------
107   *   *
108   * Tcl_Main --   * Tcl_Main --
109   *   *
110   *      Main program for tclsh and most other Tcl-based applications.   *      Main program for tclsh and most other Tcl-based applications.
111   *   *
112   * Results:   * Results:
113   *      None. This procedure never returns (it exits the process when   *      None. This procedure never returns (it exits the process when
114   *      it's done.   *      it's done.
115   *   *
116   * Side effects:   * Side effects:
117   *      This procedure initializes the Tcl world and then starts   *      This procedure initializes the Tcl world and then starts
118   *      interpreting commands;  almost anything could happen, depending   *      interpreting commands;  almost anything could happen, depending
119   *      on the script being interpreted.   *      on the script being interpreted.
120   *   *
121   *----------------------------------------------------------------------   *----------------------------------------------------------------------
122   */   */
123    
124  void  void
125  Tcl_Main(argc, argv, appInitProc)  Tcl_Main(argc, argv, appInitProc)
126      int argc;                   /* Number of arguments. */      int argc;                   /* Number of arguments. */
127      char **argv;                /* Array of argument strings. */      char **argv;                /* Array of argument strings. */
128      Tcl_AppInitProc *appInitProc;      Tcl_AppInitProc *appInitProc;
129                                  /* Application-specific initialization                                  /* Application-specific initialization
130                                   * procedure to call after most                                   * procedure to call after most
131                                   * initialization but before starting to                                   * initialization but before starting to
132                                   * execute commands. */                                   * execute commands. */
133  {  {
134      Tcl_Obj *resultPtr;      Tcl_Obj *resultPtr;
135      Tcl_Obj *commandPtr = NULL;      Tcl_Obj *commandPtr = NULL;
136      char buffer[1000], *args;      char buffer[1000], *args;
137      int code, gotPartial, tty, length;      int code, gotPartial, tty, length;
138      int exitCode = 0;      int exitCode = 0;
139      Tcl_Channel inChannel, outChannel, errChannel;      Tcl_Channel inChannel, outChannel, errChannel;
140      Tcl_Interp *interp;      Tcl_Interp *interp;
141      Tcl_DString argString;      Tcl_DString argString;
142    
143      Tcl_FindExecutable(argv[0]);      Tcl_FindExecutable(argv[0]);
144      interp = Tcl_CreateInterp();      interp = Tcl_CreateInterp();
145  #ifdef TCL_MEM_DEBUG  #ifdef TCL_MEM_DEBUG
146      Tcl_InitMemory(interp);      Tcl_InitMemory(interp);
147  #endif  #endif
148    
149      /*      /*
150       * Make command-line arguments available in the Tcl variables "argc"       * Make command-line arguments available in the Tcl variables "argc"
151       * and "argv".  If the first argument doesn't start with a "-" then       * and "argv".  If the first argument doesn't start with a "-" then
152       * strip it off and use it as the name of a script file to process.       * strip it off and use it as the name of a script file to process.
153       */       */
154    
155      if (tclStartupScriptFileName == NULL) {      if (tclStartupScriptFileName == NULL) {
156          if ((argc > 1) && (argv[1][0] != '-')) {          if ((argc > 1) && (argv[1][0] != '-')) {
157              tclStartupScriptFileName = argv[1];              tclStartupScriptFileName = argv[1];
158              argc--;              argc--;
159              argv++;              argv++;
160          }          }
161      }      }
162      args = Tcl_Merge(argc-1, argv+1);      args = Tcl_Merge(argc-1, argv+1);
163      Tcl_ExternalToUtfDString(NULL, args, -1, &argString);      Tcl_ExternalToUtfDString(NULL, args, -1, &argString);
164      Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);      Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
165      Tcl_DStringFree(&argString);      Tcl_DStringFree(&argString);
166      ckfree(args);      ckfree(args);
167    
168      if (tclStartupScriptFileName == NULL) {      if (tclStartupScriptFileName == NULL) {
169          Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString);          Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString);
170      } else {      } else {
171          tclStartupScriptFileName = Tcl_ExternalToUtfDString(NULL,          tclStartupScriptFileName = Tcl_ExternalToUtfDString(NULL,
172                  tclStartupScriptFileName, -1, &argString);                  tclStartupScriptFileName, -1, &argString);
173      }      }
174    
175      TclFormatInt(buffer, argc-1);      TclFormatInt(buffer, argc-1);
176      Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);      Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
177      Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);      Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
178    
179      /*      /*
180       * Set the "tcl_interactive" variable.       * Set the "tcl_interactive" variable.
181       */       */
182    
183      tty = isatty(0);      tty = isatty(0);
184      Tcl_SetVar(interp, "tcl_interactive",      Tcl_SetVar(interp, "tcl_interactive",
185              ((tclStartupScriptFileName == NULL) && tty) ? "1" : "0",              ((tclStartupScriptFileName == NULL) && tty) ? "1" : "0",
186              TCL_GLOBAL_ONLY);              TCL_GLOBAL_ONLY);
187            
188      /*      /*
189       * Invoke application-specific initialization.       * Invoke application-specific initialization.
190       */       */
191    
192       /* Register any extensions that should be registered for the       /* Register any extensions that should be registered for the
193       ** executable currently being built.       ** executable currently being built.
194       */       */
195     ExtninitInit(interp);     ExtninitInit(interp);
196    
197     /* Set a Tcl variable to indicate the particular product     /* Set a Tcl variable to indicate the particular product
198     ** we are building.  This is used in the startup message script     ** we are building.  This is used in the startup message script
199     ** to announce product version, and may be used other     ** to announce product version, and may be used other
200     ** places, as well.     ** places, as well.
201     */     */
202     Tcl_SetVar(interp,     Tcl_SetVar(interp,
203                BUILD_CONFIG_PRODUCT_NAME_VARIABLE,                BUILD_CONFIG_PRODUCT_NAME_VARIABLE,
204                BUILD_CONFIG_STATIC_TCLSH_ALIAS,                BUILD_CONFIG_STATIC_TCLSH_ALIAS,
205                TCL_GLOBAL_ONLY);                TCL_GLOBAL_ONLY);
206    
207     /* Set  Tcl variable to indicate the relese version of the     /* Set  Tcl variable to indicate the relese version of the
208     ** product we are building.  This is used in the startup message script     ** product we are building.  This is used in the startup message script
209     ** to announce product version, and may be used other     ** to announce product version, and may be used other
210     ** places, as well.     ** places, as well.
211     */     */
212     Tcl_SetVar(interp,     Tcl_SetVar(interp,
213                BUILD_CONFIG_PRODUCT_VERSION_VARIABLE,                BUILD_CONFIG_PRODUCT_VERSION_VARIABLE,
214                BUILD_CONFIG_RELEASE_VERSION,                BUILD_CONFIG_RELEASE_VERSION,
215                TCL_GLOBAL_ONLY);                TCL_GLOBAL_ONLY);
216    
217     /* Output the introductory message to the console.     /* Output the introductory message to the console.
218     ** The script called is generic and applies to both     ** The script called is generic and applies to both
219     ** IjuScripter and IjuConsole.     ** IjuScripter and IjuConsole.
220     */     */
221     Tcl_GlobalEval(interp, BUILD_CONFIG_StartupMessageScript);     Tcl_GlobalEval(interp, BUILD_CONFIG_StartupMessageScript);
222    
223      /*      /*
224       * If a script file was specified then just source that file       * If a script file was specified then just source that file
225       * and quit.       * and quit.
226       */       */
227    
228      if (tclStartupScriptFileName != NULL) {      if (tclStartupScriptFileName != NULL) {
229          code = Tcl_EvalFile(interp, tclStartupScriptFileName);          code = Tcl_EvalFile(interp, tclStartupScriptFileName);
230          if (code != TCL_OK) {          if (code != TCL_OK) {
231              errChannel = Tcl_GetStdChannel(TCL_STDERR);              errChannel = Tcl_GetStdChannel(TCL_STDERR);
232              if (errChannel) {              if (errChannel) {
233                  /*                  /*
234                   * The following statement guarantees that the errorInfo                   * The following statement guarantees that the errorInfo
235                   * variable is set properly.                   * variable is set properly.
236                   */                   */
237    
238                  Tcl_AddErrorInfo(interp, "");                  Tcl_AddErrorInfo(interp, "");
239                  Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo",                  Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo",
240                          NULL, TCL_GLOBAL_ONLY));                          NULL, TCL_GLOBAL_ONLY));
241                  Tcl_WriteChars(errChannel, "\n", 1);                  Tcl_WriteChars(errChannel, "\n", 1);
242              }              }
243              exitCode = 1;              exitCode = 1;
244          }          }
245          goto done;          goto done;
246      }      }
247      Tcl_DStringFree(&argString);      Tcl_DStringFree(&argString);
248    
249      /*      /*
250       * We're running interactively.  Source a user-specific startup       * We're running interactively.  Source a user-specific startup
251       * file if the application specified one and if the file exists.       * file if the application specified one and if the file exists.
252       */       */
253    
254      Tcl_SourceRCFile(interp);      Tcl_SourceRCFile(interp);
255    
256      /*      /*
257       * Process commands from stdin until there's an end-of-file.  Note       * Process commands from stdin until there's an end-of-file.  Note
258       * that we need to fetch the standard channels again after every       * that we need to fetch the standard channels again after every
259       * eval, since they may have been changed.       * eval, since they may have been changed.
260       */       */
261    
262      commandPtr = Tcl_NewObj();      commandPtr = Tcl_NewObj();
263      Tcl_IncrRefCount(commandPtr);      Tcl_IncrRefCount(commandPtr);
264    
265      inChannel = Tcl_GetStdChannel(TCL_STDIN);      inChannel = Tcl_GetStdChannel(TCL_STDIN);
266      outChannel = Tcl_GetStdChannel(TCL_STDOUT);      outChannel = Tcl_GetStdChannel(TCL_STDOUT);
267      gotPartial = 0;      gotPartial = 0;
268      while (1) {      while (1) {
269          if (tty) {          if (tty) {
270              Tcl_Obj *promptCmdPtr;              Tcl_Obj *promptCmdPtr;
271    
272              promptCmdPtr = Tcl_GetVar2Ex(interp,              promptCmdPtr = Tcl_GetVar2Ex(interp,
273                      (gotPartial ? "tcl_prompt2" : "tcl_prompt1"),                      (gotPartial ? "tcl_prompt2" : "tcl_prompt1"),
274                      NULL, TCL_GLOBAL_ONLY);                      NULL, TCL_GLOBAL_ONLY);
275              if (promptCmdPtr == NULL) {              if (promptCmdPtr == NULL) {
276                  defaultPrompt:                  defaultPrompt:
277                  if (!gotPartial && outChannel) {                  if (!gotPartial && outChannel) {
278                      Tcl_WriteChars(outChannel, "% ", 2);                      Tcl_WriteChars(outChannel, "% ", 2);
279                  }                  }
280              } else {              } else {
281                  code = Tcl_EvalObjEx(interp, promptCmdPtr, 0);                  code = Tcl_EvalObjEx(interp, promptCmdPtr, 0);
282                  inChannel = Tcl_GetStdChannel(TCL_STDIN);                  inChannel = Tcl_GetStdChannel(TCL_STDIN);
283                  outChannel = Tcl_GetStdChannel(TCL_STDOUT);                  outChannel = Tcl_GetStdChannel(TCL_STDOUT);
284                  errChannel = Tcl_GetStdChannel(TCL_STDERR);                  errChannel = Tcl_GetStdChannel(TCL_STDERR);
285                  if (code != TCL_OK) {                  if (code != TCL_OK) {
286                      if (errChannel) {                      if (errChannel) {
287                          Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));                          Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
288                          Tcl_WriteChars(errChannel, "\n", 1);                          Tcl_WriteChars(errChannel, "\n", 1);
289                      }                      }
290                      Tcl_AddErrorInfo(interp,                      Tcl_AddErrorInfo(interp,
291                              "\n    (script that generates prompt)");                              "\n    (script that generates prompt)");
292                      goto defaultPrompt;                      goto defaultPrompt;
293                  }                  }
294              }              }
295              if (outChannel) {              if (outChannel) {
296                  Tcl_Flush(outChannel);                  Tcl_Flush(outChannel);
297              }              }
298          }          }
299          if (!inChannel) {          if (!inChannel) {
300              goto done;              goto done;
301          }          }
302          length = Tcl_GetsObj(inChannel, commandPtr);          length = Tcl_GetsObj(inChannel, commandPtr);
303          if (length < 0) {          if (length < 0) {
304              goto done;              goto done;
305          }          }
306          if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {          if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
307              goto done;              goto done;
308          }          }
309    
310          /*          /*
311           * Add the newline removed by Tcl_GetsObj back to the string.           * Add the newline removed by Tcl_GetsObj back to the string.
312           */           */
313    
314          Tcl_AppendToObj(commandPtr, "\n", 1);          Tcl_AppendToObj(commandPtr, "\n", 1);
315          if (!TclObjCommandComplete(commandPtr)) {          if (!TclObjCommandComplete(commandPtr)) {
316              gotPartial = 1;              gotPartial = 1;
317              continue;              continue;
318          }          }
319    
320          gotPartial = 0;          gotPartial = 0;
321          code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);          code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
322          inChannel = Tcl_GetStdChannel(TCL_STDIN);          inChannel = Tcl_GetStdChannel(TCL_STDIN);
323          outChannel = Tcl_GetStdChannel(TCL_STDOUT);          outChannel = Tcl_GetStdChannel(TCL_STDOUT);
324          errChannel = Tcl_GetStdChannel(TCL_STDERR);          errChannel = Tcl_GetStdChannel(TCL_STDERR);
325          Tcl_DecrRefCount(commandPtr);          Tcl_DecrRefCount(commandPtr);
326          commandPtr = Tcl_NewObj();          commandPtr = Tcl_NewObj();
327          Tcl_IncrRefCount(commandPtr);          Tcl_IncrRefCount(commandPtr);
328          if (code != TCL_OK) {          if (code != TCL_OK) {
329              if (errChannel) {              if (errChannel) {
330                  Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));                  Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
331                  Tcl_WriteChars(errChannel, "\n", 1);                  Tcl_WriteChars(errChannel, "\n", 1);
332              }              }
333          } else if (tty) {          } else if (tty) {
334              resultPtr = Tcl_GetObjResult(interp);              resultPtr = Tcl_GetObjResult(interp);
335              Tcl_GetStringFromObj(resultPtr, &length);              Tcl_GetStringFromObj(resultPtr, &length);
336              if ((length > 0) && outChannel) {              if ((length > 0) && outChannel) {
337                  Tcl_WriteObj(outChannel, resultPtr);                  Tcl_WriteObj(outChannel, resultPtr);
338                  Tcl_WriteChars(outChannel, "\n", 1);                  Tcl_WriteChars(outChannel, "\n", 1);
339              }              }
340          }          }
341  #ifdef TCL_MEM_DEBUG  #ifdef TCL_MEM_DEBUG
342          if (tclMemDumpFileName != NULL) {          if (tclMemDumpFileName != NULL) {
343              Tcl_DecrRefCount(commandPtr);              Tcl_DecrRefCount(commandPtr);
344              Tcl_DeleteInterp(interp);              Tcl_DeleteInterp(interp);
345              Tcl_Exit(0);              Tcl_Exit(0);
346          }          }
347  #endif  #endif
348      }      }
349    
350      /*      /*
351       * Rather than calling exit, invoke the "exit" command so that       * Rather than calling exit, invoke the "exit" command so that
352       * users can replace "exit" with some other command to do additional       * users can replace "exit" with some other command to do additional
353       * cleanup on exit.  The Tcl_Eval call should never return.       * cleanup on exit.  The Tcl_Eval call should never return.
354       */       */
355    
356      done:      done:
357      if (commandPtr != NULL) {      if (commandPtr != NULL) {
358          Tcl_DecrRefCount(commandPtr);          Tcl_DecrRefCount(commandPtr);
359      }      }
360      sprintf(buffer, "exit %d", exitCode);      sprintf(buffer, "exit %d", exitCode);
361      Tcl_Eval(interp, buffer);      Tcl_Eval(interp, buffer);
362  }  }
363    
364    
365  const char *TclMainCversion(void)  const char *TclMainCversion(void)
366  {    {  
367      return ("$Header$");      return ("$Header$");
368  }  }
369    
370    
371  const char *TclMainHversion(void)  const char *TclMainHversion(void)
372  {    {  
373      return (TCLMAIN_H_VERSION);      return (TCLMAIN_H_VERSION);
374  }  }
375    
376  /* End of tclmain.c */  /* End of tclmain.c */

Legend:
Removed from v.64  
changed lines
  Added in v.71

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25