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