PLplot  5.10.0
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros
tclMain.c
Go to the documentation of this file.
1 // Modified version of tclMain.c, from Tcl 8.3.2.
2 // Maurice LeBrun
3 // Jan 2 2001
4 //
5 // Copyright (C) 2004 Joao Cardoso
6 //
7 // This file is part of PLplot.
8 //
9 // PLplot is free software; you can redistribute it and/or modify
10 // it under the terms of the GNU Library General Public License as published
11 // by the Free Software Foundation; either version 2 of the License, or
12 // (at your option) any later version.
13 //
14 // PLplot is distributed in the hope that it will be useful,
15 // but WITHOUT ANY WARRANTY; without even the implied warranty of
16 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 // GNU Library General Public License for more details.
18 //
19 // You should have received a copy of the GNU Library General Public License
20 // along with PLplot; if not, write to the Free Software
21 // Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
22 //
23 //
24 // Based on previous version of tclMain.c, from Tcl 7.3.
25 // Modifications include:
26 // 1. Tcl_Main() changed to pltclMain().
27 // 2. Changes to work with ANSI C
28 // 3. Changes to support user-installable error or output handlers.
29 // 4. PLplot argument parsing routine called to handle arguments.
30 // 5. Added define of _POSIX_SOURCE and eliminated include of tclInt.h.
31 //
32 // Original comments follow.
33 //
34 
35 //
36 // tclMain.c --
37 //
38 // Main program for Tcl shells and other Tcl-based applications.
39 //
40 // Copyright (c) 1988-1994 The Regents of the University of California.
41 // Copyright (c) 1994-1997 Sun Microsystems, Inc.
42 //
43 // See the file "license.terms" for information on usage and redistribution
44 // of this file, and for a DISCLAIMER OF ALL WARRANTIES.
45 //
46 
47 #include "pltcl.h"
48 // Required for definition of PL_UNUSED macro
49 #include "plplotP.h"
50 
51 #define TclFormatInt( buf, n ) sprintf( ( buf ), "%ld", (long) ( n ) )
52 
53 # undef TCL_STORAGE_CLASS
54 # define TCL_STORAGE_CLASS DLLEXPORT
55 
56 //
57 // The following code ensures that tclLink.c is linked whenever
58 // Tcl is linked. Without this code there's no reference to the
59 // code in that file from anywhere in Tcl, so it may not be
60 // linked into the application.
61 //
62 
63 // Experiments show this is no longer required, and in any case
64 // it screws up using the Tcl stub library. So comment out (AWI).
65 //EXTERN int Tcl_LinkVar( );
66 //int ( *tclDummyLinkVarPtr )() = Tcl_LinkVar;
67 
68 //
69 // Declarations for various library procedures and variables (don't want
70 // to include tclPort.h here, because people might copy this file out of
71 // the Tcl source directory to make their own modified versions).
72 // Note: "exit" should really be declared here, but there's no way to
73 // declare it without causing conflicts with other definitions elsewher
74 // on some systems, so it's better just to leave it out.
75 //
76 
77 extern int isatty _ANSI_ARGS_( (int fd) );
78 extern char * strcpy _ANSI_ARGS_( ( char *dst, CONST char *src ) );
79 
80 static const char *tclStartupScriptFileName = NULL;
81 
82 // pltcl enhancements
83 
84 static void
85 plPrepOutputHandler( Tcl_Interp *interp, int code, int tty );
86 
87 // Other function prototypes
89 const char *TclGetStartupScriptFileName( void );
90 
91 // These are globally visible and can be replaced
92 
93 void ( *tclErrorHandler )( Tcl_Interp *interp, int code, int tty ) = NULL;
94 
95 void ( *tclPrepOutputHandler )( Tcl_Interp *interp, int code, int tty )
97 
98 // Options data structure definition.
99 
100 static char *tclStartupScript = NULL;
101 static const char *pltcl_notes[] = {
102  "Specifying the filename on the command line is compatible with modern",
103  "tclsh syntax. Old tclsh's used the -f syntax, which is still supported.",
104  "You may use either syntax but not both.",
105  NULL
106 };
107 
108 static PLOptionTable options[] = {
109  {
110  "f", // File to read & process
111  NULL,
112  NULL,
115  "-f",
116  "File from which to read commands"
117  },
118  {
119  "file", // File to read & process (alias)
120  NULL,
121  NULL,
124  "-file",
125  "File from which to read commands"
126  },
127  {
128  "e", // Script to run on startup
129  NULL,
130  NULL,
133  "-e",
134  "Script to execute on startup"
135  },
136  {
137  NULL, // option
138  NULL, // handler
139  NULL, // client data
140  NULL, // address of variable to set
141  0, // mode flag
142  NULL, // short syntax
143  NULL
144  } // long syntax
145 };
146 
147 
148 //
149 //--------------------------------------------------------------------------
150 //
151 // TclSetStartupScriptFileName --
152 //
153 // Primes the startup script file name, used to override the
154 // command line processing.
155 //
156 // Results:
157 // None.
158 //
159 // Side effects:
160 // This procedure initializes the file name of the Tcl script to
161 // run at startup.
162 //
163 //--------------------------------------------------------------------------
164 //
166 {
167  tclStartupScriptFileName = fileName;
168 }
169 
170 
171 //
172 //--------------------------------------------------------------------------
173 //
174 // TclGetStartupScriptFileName --
175 //
176 // Gets the startup script file name, used to override the
177 // command line processing.
178 //
179 // Results:
180 // The startup script file name, NULL if none has been set.
181 //
182 // Side effects:
183 // None.
184 //
185 //--------------------------------------------------------------------------
186 //
187 const char *TclGetStartupScriptFileName( void )
188 {
190 }
191 
192 
193 
194 //
195 //--------------------------------------------------------------------------
196 //
197 // Tcl_Main --
198 //
199 // Main program for tclsh and most other Tcl-based applications.
200 //
201 // Results:
202 // None. This procedure never returns (it exits the process when
203 // it's done.
204 //
205 // Side effects:
206 // This procedure initializes the Tcl world and then starts
207 // interpreting commands; almost anything could happen, depending
208 // on the script being interpreted.
209 //
210 //--------------------------------------------------------------------------
211 //
212 
213 int PLDLLEXPORT
214 pltclMain( int argc, const char **argv, char * PL_UNUSED( RcFileName ) /* OBSOLETE */,
215  int ( *appInitProc )( Tcl_Interp *interp ) )
216 {
217  Tcl_Obj *resultPtr;
218  Tcl_Obj *commandPtr = NULL;
219  char buffer[1000], *args;
220  int code, gotPartial, tty, length;
221  int exitCode = 0;
222  Tcl_Channel inChannel, outChannel, errChannel;
223  Tcl_Interp *interp;
224  Tcl_DString argString;
225 
226  char usage[500];
227 
228  Tcl_FindExecutable( argv[0] );
229  interp = Tcl_CreateInterp();
230  Tcl_InitMemory( interp ); //no-op if TCL_MEM_DEBUG undefined
231 
232  // First process plplot-specific args using the PLplot parser.
233 
234  sprintf( usage, "\nUsage:\n %s [filename] [options]\n", argv[0] );
235  plSetUsage( NULL, usage );
236  plMergeOpts( options, "pltcl options", pltcl_notes );
237  (void) plparseopts( &argc, argv, PL_PARSE_FULL | PL_PARSE_SKIP );
238 
239  //
240  // Make (remaining) command-line arguments available in the Tcl variables
241  // "argc" and "argv". If the first argument doesn't start with a "-" then
242  // strip it off and use it as the name of a script file to process.
243  //
244 
245  if ( tclStartupScriptFileName == NULL )
246  {
247  if ( ( argc > 1 ) && ( argv[1][0] != '-' ) )
248  {
249  tclStartupScriptFileName = argv[1];
250  argc--;
251  argv++;
252  }
253  }
254  args = Tcl_Merge( argc - 1, ( CONST char * CONST * )argv + 1 );
255  Tcl_ExternalToUtfDString( NULL, args, -1, &argString );
256  Tcl_SetVar( interp, "argv", Tcl_DStringValue( &argString ), TCL_GLOBAL_ONLY );
257  Tcl_DStringFree( &argString );
258  ckfree( args );
259 
260  if ( tclStartupScriptFileName == NULL )
261  {
262  Tcl_ExternalToUtfDString( NULL, argv[0], -1, &argString );
263  }
264  else
265  {
266  tclStartupScriptFileName = Tcl_ExternalToUtfDString( NULL,
267  tclStartupScriptFileName, -1, &argString );
268  }
269 
270  TclFormatInt( buffer, argc - 1 );
271  Tcl_SetVar( interp, "argc", buffer, TCL_GLOBAL_ONLY );
272  Tcl_SetVar( interp, "argv0", Tcl_DStringValue( &argString ), TCL_GLOBAL_ONLY );
273 
274  //
275  // Set the "tcl_interactive" variable.
276  //
277 
278  tty = isatty( 0 );
279  Tcl_SetVar( interp, "tcl_interactive",
280  ( ( tclStartupScriptFileName == NULL ) && tty ) ? "1" : "0",
281  TCL_GLOBAL_ONLY );
282 
283  //
284  // Invoke application-specific initialization.
285  //
286 
287  if ( ( *appInitProc )( interp ) != TCL_OK )
288  {
289  errChannel = Tcl_GetStdChannel( TCL_STDERR );
290  if ( errChannel )
291  {
292  Tcl_WriteChars( errChannel,
293  "application-specific initialization failed: ", -1 );
294  Tcl_WriteObj( errChannel, Tcl_GetObjResult( interp ) );
295  Tcl_WriteChars( errChannel, "\n", 1 );
296  }
297  }
298 
299  //
300  // Process the startup script, if any.
301  //
302 
303  if ( tclStartupScript != NULL )
304  {
305  code = Tcl_VarEval( interp, tclStartupScript, (char *) NULL );
306  if ( code != TCL_OK )
307  {
308  fprintf( stderr, "%s\n", Tcl_GetStringResult( interp ) );
309  exitCode = 1;
310  }
311  }
312 
313  //
314  // If a script file was specified then just source that file
315  // and quit.
316  //
317 
318  if ( tclStartupScriptFileName != NULL )
319  {
320  code = Tcl_EvalFile( interp, tclStartupScriptFileName );
321  if ( code != TCL_OK )
322  {
323  errChannel = Tcl_GetStdChannel( TCL_STDERR );
324  if ( errChannel )
325  {
326  //
327  // The following statement guarantees that the errorInfo
328  // variable is set properly.
329  //
330 
331  Tcl_AddErrorInfo( interp, "" );
332  Tcl_WriteObj( errChannel, Tcl_GetVar2Ex( interp, "errorInfo",
333  NULL, TCL_GLOBAL_ONLY ) );
334  Tcl_WriteChars( errChannel, "\n", 1 );
335  }
336  exitCode = 1;
337  }
338  goto done;
339  }
340  Tcl_DStringFree( &argString );
341 
342  //
343  // We're running interactively. Source a user-specific startup
344  // file if the application specified one and if the file exists.
345  //
346 
347  Tcl_SourceRCFile( interp );
348 
349  //
350  // Process commands from stdin until there's an end-of-file. Note
351  // that we need to fetch the standard channels again after every
352  // eval, since they may have been changed.
353  //
354 
355  commandPtr = Tcl_NewObj();
356  Tcl_IncrRefCount( commandPtr );
357 
358  inChannel = Tcl_GetStdChannel( TCL_STDIN );
359  outChannel = Tcl_GetStdChannel( TCL_STDOUT );
360  gotPartial = 0;
361  while ( 1 )
362  {
363  if ( tty )
364  {
365  Tcl_Obj *promptCmdPtr;
366 
367  promptCmdPtr = Tcl_GetVar2Ex( interp,
368  ( gotPartial ? "tcl_prompt2" : "tcl_prompt1" ),
369  NULL, TCL_GLOBAL_ONLY );
370  if ( promptCmdPtr == NULL )
371  {
372 defaultPrompt:
373  if ( !gotPartial && outChannel )
374  {
375  Tcl_WriteChars( outChannel, "% ", 2 );
376  }
377  }
378  else
379  {
380  code = Tcl_EvalObjEx( interp, promptCmdPtr, 0 );
381  inChannel = Tcl_GetStdChannel( TCL_STDIN );
382  outChannel = Tcl_GetStdChannel( TCL_STDOUT );
383  errChannel = Tcl_GetStdChannel( TCL_STDERR );
384  if ( code != TCL_OK )
385  {
386  if ( errChannel )
387  {
388  Tcl_WriteObj( errChannel, Tcl_GetObjResult( interp ) );
389  Tcl_WriteChars( errChannel, "\n", 1 );
390  }
391  Tcl_AddErrorInfo( interp,
392  "\n (script that generates prompt)" );
393  goto defaultPrompt;
394  }
395  }
396  if ( outChannel )
397  {
398  Tcl_Flush( outChannel );
399  }
400  }
401  if ( !inChannel )
402  {
403  goto done;
404  }
405  length = Tcl_GetsObj( inChannel, commandPtr );
406  if ( length < 0 )
407  {
408  goto done;
409  }
410  if ( ( length == 0 ) && Tcl_Eof( inChannel ) && ( !gotPartial ) )
411  {
412  goto done;
413  }
414 
415  //
416  // Add the newline removed by Tcl_GetsObj back to the string.
417  //
418 
419  Tcl_AppendToObj( commandPtr, "\n", 1 );
420  if ( !Tcl_CommandComplete( Tcl_GetString( commandPtr ) ) )
421  {
422  gotPartial = 1;
423  continue;
424  }
425 
426  gotPartial = 0;
427  code = Tcl_RecordAndEvalObj( interp, commandPtr, 0 );
428  inChannel = Tcl_GetStdChannel( TCL_STDIN );
429  outChannel = Tcl_GetStdChannel( TCL_STDOUT );
430  errChannel = Tcl_GetStdChannel( TCL_STDERR );
431  Tcl_DecrRefCount( commandPtr );
432  commandPtr = Tcl_NewObj();
433  Tcl_IncrRefCount( commandPtr );
434 
435  // User defined function to deal with tcl command output
436  // Deprecated; for backward compatibility only
437  if ( ( ( code != TCL_OK ) || tty ) && tclErrorHandler )
438  ( *tclErrorHandler )( interp, code, tty );
439  else
440  {
441  // User defined function to prepare for tcl output
442  // This is the new way
443  if ( ( ( code != TCL_OK ) || tty ) && tclPrepOutputHandler )
444  ( *tclPrepOutputHandler )( interp, code, tty );
445  // Back to the stock tcl code
446  if ( code != TCL_OK )
447  {
448  if ( errChannel )
449  {
450  Tcl_WriteObj( errChannel, Tcl_GetObjResult( interp ) );
451  Tcl_WriteChars( errChannel, "\n", 1 );
452  }
453  }
454  else if ( tty )
455  {
456  resultPtr = Tcl_GetObjResult( interp );
457  Tcl_GetStringFromObj( resultPtr, &length );
458  if ( ( length > 0 ) && outChannel )
459  {
460  Tcl_WriteObj( outChannel, resultPtr );
461  Tcl_WriteChars( outChannel, "\n", 1 );
462  }
463  }
464  }
465  }
466 
467  //
468  // Rather than calling exit, invoke the "exit" command so that
469  // users can replace "exit" with some other command to do additional
470  // cleanup on exit. The Tcl_Eval call should never return.
471  //
472 
473 done:
474  if ( commandPtr != NULL )
475  {
476  Tcl_DecrRefCount( commandPtr );
477  }
478  sprintf( buffer, "exit %d", exitCode );
479  Tcl_Eval( interp, buffer );
480  return 0; // to silence warnings
481 }
482 
483 //
484 //--------------------------------------------------------------------------
485 //
486 // plPrepOutputHandler --
487 //
488 // Prepares for output during command parsing. We use it here to
489 // ensure we are on the text screen before issuing the error message,
490 // otherwise it may disappear.
491 //
492 // Results:
493 // None.
494 //
495 // Side effects:
496 // For some graphics devices, a switch between graphics and text modes
497 // is done.
498 //
499 //--------------------------------------------------------------------------
500 //
501 
502 static void
503 plPrepOutputHandler( Tcl_Interp *PL_UNUSED( interp ), int PL_UNUSED( code ), int PL_UNUSED( tty ) )
504 {
505  pltext();
506 }