1 // Modified version of tkMain.c, from Tk 3.6.
2 // Maurice LeBrun
3 // 23-Jun-1994
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 // Modifications include:
25 // 1. main() changed to pltkMain().
26 // 2. tcl_RcFileName -> RcFileName, now passed in through the argument list.
27 // 3. Tcl_AppInit -> AppInit, now passed in through the argument list.
28 // 4. Support for -e <script> startup option
29 //
30 // The original notes follow.
31 //
32
33 //
34 // main.c --
35 //
36 // This file contains the main program for "wish", a windowing
37 // shell based on Tk and Tcl. It also provides a template that
38 // can be used as the basis for main programs for other Tk
39 // applications.
40 //
41 // Copyright (c) 1990-1993 The Regents of the University of California.
42 // All rights reserved.
43 //
44 // Permission is hereby granted, without written agreement and without
45 // license or royalty fees, to use, copy, modify, and distribute this
46 // software and its documentation for any purpose, provided that the
47 // above copyright notice and the following two paragraphs appear in
48 // all copies of this software.
49 //
50 // IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
51 // DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
52 // OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
53 // CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
54 //
55 // THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
56 // INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
57 // AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
58 // ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
59 // PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
60 //
61
62 #include "plplotP.h"
63 #include "pltkd.h"
64 #include <stdio.h>
65 #include <stdlib.h>
66 #include <tcl.h>
67 #include <tk.h>
68 #ifdef HAVE_ITCL
69 # ifndef HAVE_ITCLDECLS_H
70 # define RESOURCE_INCLUDED
71 # endif
72 # include <itcl.h>
73 #endif
74
75 // itk.h includes itclInt.h which includes tclInt.h ...disaster -mjl
76 // #ifdef HAVE_ITK
77 // #include <itk.h>
78 // #endif
79
80 // From itkDecls.h
81
82 EXTERN int Itk_Init _ANSI_ARGS_( ( Tcl_Interp * interp ) );
83
84 // From tclIntDecls.h
85
86 //#ifndef Tcl_Import_TCL_DECLARED
87 #if 0
88 EXTERN int Tcl_Import _ANSI_ARGS_( ( Tcl_Interp * interp,
89 Tcl_Namespace * nsPtr, char * pattern,
90 int allowOverwrite ) );
91 #endif
92
93 #ifndef Tcl_GetGlobalNamespace_TCL_DECLARE
94 EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace _ANSI_ARGS_( (
95 Tcl_Interp * interp ) );
96 #endif
97
98 //
99 // Declarations for various library procedures and variables (don't want
100 // to include tkInt.h or tkConfig.h here, because people might copy this
101 // file out of the Tk source directory to make their own modified versions).
102 //
103
104 // these are defined in unistd.h, included by plplotP.h
105 // extern void exit _ANSI_ARGS_((int status));
106 // extern int isatty _ANSI_ARGS_((int fd));
107 // extern int read _ANSI_ARGS_((int fd, char *buf, size_t size));
108 //
109 #if !defined ( _WIN32 )
110 extern char * strrchr _ANSI_ARGS_( ( CONST char *string, int c ) );
111 #else
112 // On Windows we do not have a convenient console to work with
113 #define isatty( a ) 0
114 #endif
115
116 //
117 // Global variables used by the main program:
118 //
119
120 static Tcl_Interp *interp; // Interpreter for this application.
121 static Tcl_DString command; // Used to assemble lines of terminal input
122 // into Tcl commands.
123 static int tty; // Non-zero means standard input is a
124 // terminal-like device. Zero means it's
125 // a file.
126 static char errorExitCmd[] = "exit 1";
127
128 //
129 // Command-line options:
130 //
131
132 static int synchronize = 0;
133 static const char *script = NULL;
134 static const char *fileName = NULL;
135 static const char *name = NULL;
136 static const char *display = NULL;
137 static const char *geometry = NULL;
138
139 static Tk_ArgvInfo argTable[] = {
140 { "-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName,
141 "File from which to read commands" },
142 { "-e", TK_ARGV_STRING, (char *) NULL, (char *) &script,
143 "Script to execute on startup" },
144 { "-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry,
145 "Initial geometry for window" },
146 { "-display", TK_ARGV_STRING, (char *) NULL, (char *) &display,
147 "Display to use" },
148 { "-name", TK_ARGV_STRING, (char *) NULL, (char *) &name,
149 "Name to use for application" },
150 { "-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize,
151 "Use synchronous mode for display server" },
152 { (char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL,
153 (char *) NULL }
154 };
155
156 //
157 // Forward declarations for procedures defined later in this file:
158 //
159
160 static void Prompt _ANSI_ARGS_( ( Tcl_Interp * interploc, int partial ) );
161 static void StdinProc _ANSI_ARGS_( ( ClientData clientData,
162 int mask ) );
163
164 //
165 //--------------------------------------------------------------------------
166 //
167 // main --
168 //
169 // Main program for Wish.
170 //
171 // Results:
172 // None. This procedure never returns (it exits the process when
173 // it's done
174 //
175 // Side effects:
176 // This procedure initializes the wish world and then starts
177 // interpreting commands; almost anything could happen, depending
178 // on the script being interpreted.
179 //
180 //--------------------------------------------------------------------------
181 //
182
183 int
pltkMain(int argc,const char ** argv,char * RcFileName,int (* AppInit)(Tcl_Interp * interp))184 pltkMain( int argc, const char **argv, char *RcFileName,
185 int ( *AppInit )( Tcl_Interp *interp ) )
186 {
187 char *args;
188 const char *msg, *p;
189 char buf[20];
190 int code;
191
192 #ifdef PL_HAVE_PTHREAD
193 XInitThreads();
194 #endif
195
196 Tcl_FindExecutable( argv[0] );
197 interp = Tcl_CreateInterp();
198 #ifdef TCL_MEM_DEBUG
199 Tcl_InitMemory( interp );
200 #endif
201
202 //
203 // Parse command-line arguments.
204 //
205 //fprintf( stderr, "Before Tk_ParseArgv\n" );
206
207 if ( Tk_ParseArgv( interp, (Tk_Window) NULL, &argc, argv, argTable, 0 )
208 != TCL_OK )
209 {
210 fprintf( stderr, "%s\n", Tcl_GetStringResult( interp ) );
211 exit( 1 );
212 }
213 //fprintf( stderr, "After Tk_ParseArgv\n" );
214 if ( name == NULL )
215 {
216 if ( fileName != NULL )
217 {
218 p = fileName;
219 }
220 else
221 {
222 p = argv[0];
223 }
224 name = strrchr( p, '/' );
225 if ( name != NULL )
226 {
227 name++;
228 }
229 else
230 {
231 name = p;
232 }
233 }
234
235 //
236 // If a display was specified, put it into the DISPLAY
237 // environment variable so that it will be available for
238 // any sub-processes created by us.
239 //
240
241 if ( display != NULL )
242 {
243 Tcl_SetVar2( interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY );
244 }
245
246 //
247 // Initialize the Tk application.
248 //
249
250 //
251 // This must be setup *before* calling Tk_Init,
252 // and `name' has already been setup above
253 //
254
255 Tcl_SetVar( interp, "argv0", name, TCL_GLOBAL_ONLY );
256
257 if ( Tcl_Init( interp ) == TCL_ERROR )
258 {
259 fprintf( stderr, "Tcl initialisation failed: %s\n", Tcl_GetStringResult( interp ) );
260 return TCL_ERROR;
261 }
262 if ( Tk_Init( interp ) == TCL_ERROR )
263 {
264 fprintf( stderr, "Tk initialisation failed: %s\n", Tcl_GetStringResult( interp ) );
265 return TCL_ERROR;
266 }
267 #ifdef HAVE_ITCL
268 if ( Itcl_Init( interp ) == TCL_ERROR )
269 {
270 fprintf( stderr, "Itcl initialisation failed: %s\n", Tcl_GetStringResult( interp ) );
271 return TCL_ERROR;
272 }
273 #endif
274 #ifdef HAVE_ITK
275 if ( Itk_Init( interp ) == TCL_ERROR )
276 {
277 fprintf( stderr, "Itk initialisation failed: %s\n", Tcl_GetStringResult( interp ) );
278 return TCL_ERROR;
279 }
280
281 //
282 // Pulled in this next section from itkwish in itcl3.0.1.
283 //
284
285 //
286 // This is itkwish, so import all [incr Tcl] commands by
287 // default into the global namespace. Fix up the autoloader
288 // to do the same.
289 //
290 if ( Tcl_Import( interp, Tcl_GetGlobalNamespace( interp ),
291 "::itk::*", /* allowOverwrite */ 1 ) != TCL_OK )
292 {
293 fprintf( stderr, "Itk initialisation failed: %s\n", Tcl_GetStringResult( interp ) );
294 return TCL_ERROR;
295 }
296
297 if ( Tcl_Import( interp, Tcl_GetGlobalNamespace( interp ),
298 "::itcl::*", /* allowOverwrite */ 1 ) != TCL_OK )
299 {
300 fprintf( stderr, "Itk initialisation failed: %s\n", Tcl_GetStringResult( interp ) );
301 return TCL_ERROR;
302 }
303
304 if ( Tcl_Eval( interp, "auto_mkindex_parser::slavehook { _%@namespace import -force ::itcl::* ::itk::* }" ) != TCL_OK )
305 {
306 fprintf( stderr, "Itk initialisation failed: %s\n", Tcl_GetStringResult( interp ) );
307 return TCL_ERROR;
308 }
309 #endif
310
311 //
312 // Make command-line arguments available in the Tcl variables "argc"
313 // and "argv". Also set the "geometry" variable from the geometry
314 // specified on the command line.
315 //
316 //fprintf( stderr, "Before Tcl_Merge\n" );
317
318 args = Tcl_Merge( argc - 1, ( CONST char * CONST * )argv + 1 );
319 Tcl_SetVar( interp, "argv", args, TCL_GLOBAL_ONLY );
320 ckfree( args );
321 sprintf( buf, "%d", argc - 1 );
322 Tcl_SetVar( interp, "argc", buf, TCL_GLOBAL_ONLY );
323
324 //fprintf( stderr, "After Tcl_Merge\n" );
325 if ( geometry != NULL )
326 {
327 Tcl_SetVar( interp, "geometry", geometry, TCL_GLOBAL_ONLY );
328 }
329
330 //
331 // Set the "tcl_interactive" variable.
332 //
333
334 tty = isatty( 0 );
335 Tcl_SetVar( interp, "tcl_interactive",
336 ( ( fileName == NULL ) && tty ) ? "1" : "0", TCL_GLOBAL_ONLY );
337
338 //
339 // Add a few application-specific commands to the application's
340 // interpreter.
341 //
342
343 //
344 // Invoke application-specific initialization.
345 //
346 //fprintf( stderr, "Before AppInit\n" );
347
348 if ( ( *AppInit )( interp ) != TCL_OK )
349 {
350 fprintf( stderr, "(*AppInit) failed: %s\n", Tcl_GetStringResult( interp ) );
351 return TCL_ERROR;
352 }
353
354 //
355 // Set the geometry of the main window, if requested.
356 //
357
358 if ( geometry != NULL )
359 {
360 code = Tcl_VarEval( interp, "wm geometry . ", geometry, (char *) NULL );
361 if ( code != TCL_OK )
362 {
363 fprintf( stderr, "%s\n", Tcl_GetStringResult( interp ) );
364 }
365 }
366
367 //
368 // Process the startup script, if any.
369 //
370 //fprintf( stderr, "Before startup\n" );
371
372 if ( script != NULL )
373 {
374 code = Tcl_VarEval( interp, script, (char *) NULL );
375 if ( code != TCL_OK )
376 {
377 goto error;
378 }
379 tty = 0;
380 }
381
382 //
383 // Invoke the script specified on the command line, if any.
384 //
385 //fprintf( stderr, "Before source\n" );
386
387 if ( fileName != NULL )
388 {
389 code = Tcl_VarEval( interp, "source \"", fileName, "\"", (char *) NULL );
390 if ( code != TCL_OK )
391 {
392 goto error;
393 }
394 tty = 0;
395 }
396 else
397 {
398 //
399 // Commands will come from standard input, so set up an event
400 // handler for standard input. Evaluate the .rc file, if one
401 // has been specified, set up an event handler for standard
402 // input, and print a prompt if the input device is a
403 // terminal.
404 //
405
406 if ( RcFileName != NULL )
407 {
408 Tcl_DString buffer;
409 char *fullName;
410 FILE *f;
411
412 fullName = Tcl_TildeSubst( interp, RcFileName, &buffer );
413 if ( fullName == NULL )
414 {
415 fprintf( stderr, "%s\n", Tcl_GetStringResult( interp ) );
416 }
417 else
418 {
419 f = fopen( fullName, "r" );
420 if ( f != NULL )
421 {
422 code = Tcl_EvalFile( interp, fullName );
423 if ( code != TCL_OK )
424 {
425 fprintf( stderr, "%s\n", Tcl_GetStringResult( interp ) );
426 }
427 fclose( f );
428 }
429 }
430 Tcl_DStringFree( &buffer );
431 }
432 // Exclude UNIX-only feature
433 #if !defined ( MAC_TCL ) && !defined ( _WIN32 )
434 Tk_CreateFileHandler( 0, TK_READABLE, StdinProc, (ClientData) 0 );
435 #endif
436 if ( tty )
437 {
438 Prompt( interp, 0 );
439 }
440 }
441 fflush( stdout );
442 Tcl_DStringInit( &command );
443
444 //
445 // Loop infinitely, waiting for commands to execute. When there
446 // are no windows left, Tk_MainLoop returns and we exit.
447 //
448
449 //fprintf( stderr, "Before Tk_MainLoop\n" );
450 Tk_MainLoop();
451
452 //
453 // Don't exit directly, but rather invoke the Tcl "exit" command.
454 // This gives the application the opportunity to redefine "exit"
455 // to do additional cleanup.
456 //
457
458 Tcl_Eval( interp, "exit" );
459 exit( 1 );
460
461 error:
462 msg = Tcl_GetVar( interp, "errorInfo", TCL_GLOBAL_ONLY );
463 if ( msg == NULL )
464 {
465 msg = Tcl_GetStringResult( interp );
466 }
467 fprintf( stderr, "%s\n", msg );
468 Tcl_Eval( interp, errorExitCmd );
469 return 1; // Needed only to prevent compiler warnings.
470 }
471
472 //
473 //--------------------------------------------------------------------------
474 //
475 // StdinProc --
476 //
477 // This procedure is invoked by the event dispatcher whenever
478 // standard input becomes readable. It grabs the next line of
479 // input characters, adds them to a command being assembled, and
480 // executes the command if it's complete.
481 //
482 // Results:
483 // None.
484 //
485 // Side effects:
486 // Could be almost arbitrary, depending on the command that's
487 // typed.
488 //
489 //--------------------------------------------------------------------------
490 //
491
492 // ARGSUSED
493 static void
StdinProc(ClientData PL_UNUSED (clientData),int PL_UNUSED (mask))494 StdinProc( ClientData PL_UNUSED( clientData ), int PL_UNUSED( mask ) )
495 {
496 #define BUFFER_SIZE 4000
497 char input[BUFFER_SIZE + 1];
498 static int gotPartial = 0;
499 char *cmd;
500 int code, count;
501 const char *res;
502
503 #if !defined ( _WIN32 )
504 count = (int) read( fileno( stdin ), input, BUFFER_SIZE );
505 #else
506 count = fread( input, BUFFER_SIZE, sizeof ( char ), stdin );
507 #endif
508 if ( count <= 0 )
509 {
510 if ( !gotPartial )
511 {
512 if ( tty )
513 {
514 Tcl_Eval( interp, "exit" );
515 exit( 1 );
516 }
517 else
518 {
519 #if !defined ( MAC_TCL ) && !defined ( _WIN32 )
520 Tk_DeleteFileHandler( 0 );
521 #endif
522 }
523 return;
524 }
525 else
526 {
527 count = 0;
528 }
529 }
530 cmd = Tcl_DStringAppend( &command, input, count );
531 if ( count != 0 )
532 {
533 if ( ( input[count - 1] != '\n' ) && ( input[count - 1] != ';' ) )
534 {
535 gotPartial = 1;
536 goto prompt;
537 }
538 if ( !Tcl_CommandComplete( cmd ) )
539 {
540 gotPartial = 1;
541 goto prompt;
542 }
543 }
544 gotPartial = 0;
545
546 //
547 // Disable the stdin file handler while evaluating the command;
548 // otherwise if the command re-enters the event loop we might
549 // process commands from stdin before the current command is
550 // finished. Among other things, this will trash the text of the
551 // command being evaluated.
552 //
553 #if !defined ( MAC_TCL ) && !defined ( _WIN32 )
554 Tk_CreateFileHandler( 0, 0, StdinProc, (ClientData) 0 );
555 #endif
556 code = Tcl_RecordAndEval( interp, cmd, 0 );
557 #if !defined ( MAC_TCL ) && !defined ( _WIN32 )
558 Tk_CreateFileHandler( 0, TK_READABLE, StdinProc, (ClientData) 0 );
559 #endif
560 Tcl_DStringFree( &command );
561 res = Tcl_GetStringResult( interp );
562 if ( *res != 0 )
563 {
564 if ( ( code != TCL_OK ) || ( tty ) )
565 {
566 printf( "%s\n", res );
567 }
568 }
569
570 //
571 // Output a prompt.
572 //
573
574 prompt:
575 if ( tty )
576 {
577 Prompt( interp, gotPartial );
578 }
579 }
580
581 //
582 //--------------------------------------------------------------------------
583 //
584 // Prompt --
585 //
586 // Issue a prompt on standard output, or invoke a script
587 // to issue the prompt.
588 //
589 // Results:
590 // None.
591 //
592 // Side effects:
593 // A prompt gets output, and a Tcl script may be evaluated
594 // in interp.
595 //
596 //--------------------------------------------------------------------------
597 //
598
599 static void
Prompt(interploc,partial)600 Prompt( interploc, partial )
601 Tcl_Interp * interploc; // Interpreter to use for prompting.
602 int partial; // Non-zero means there already
603 // exists a partial command, so use
604 // the secondary prompt.
605 {
606 const char *promptCmd;
607 int code;
608
609 promptCmd = Tcl_GetVar( interploc,
610 partial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY );
611 if ( promptCmd == NULL )
612 {
613 defaultPrompt:
614 if ( !partial )
615 {
616 fputs( "% ", stdout );
617 }
618 }
619 else
620 {
621 code = Tcl_Eval( interploc, promptCmd );
622 if ( code != TCL_OK )
623 {
624 Tcl_AddErrorInfo( interploc,
625 "\n (script that generates prompt)" );
626 fprintf( stderr, "%s\n", Tcl_GetStringResult( interploc ) );
627 goto defaultPrompt;
628 }
629 }
630 fflush( stdout );
631 }
632