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