PLplot: tclMain.c Source File

PLplot 5.10.0

- Main Page
- Namespaces
- Classes
- Files

- File List
- File Members

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
92 void TclSetStartupScriptFileName( char *fileName );
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 )
100 = plPrepOutputHandler;
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,
117 &tclStartupScriptFileName,
118 PL_OPT_STRING,
119 "-f",
120 "File from which to read commands"
121 },
122 {
123 "file", // File to read & process (alias)
124 NULL,
125 NULL,
126 &tclStartupScriptFileName,
127 PL_OPT_STRING | PL_OPT_INVISIBLE,
128 "-file",
129 "File from which to read commands"
130 },
131 {
132 "e", // Script to run on startup
133 NULL,
134 NULL,
135 &tclStartupScript,
136 PL_OPT_STRING,
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 //
169 void TclSetStartupScriptFileName( char *fileName )
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 {
193 return tclStartupScriptFileName;
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 }