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