PLplot  5.15.0
tkMain.c
Go to the documentation of this file.
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
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
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
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 }
static const char * name
Definition: tkMain.c:135
static char ** argv
Definition: qt.cpp:49
int pltkMain(int argc, const char **argv, char *RcFileName, int(*AppInit)(Tcl_Interp *interp))
Definition: tkMain.c:184
static int tty
Definition: tkMain.c:123
static int argc
Definition: qt.cpp:48
static char errorExitCmd[]
Definition: tkMain.c:126
static const char * geometry
Definition: tkMain.c:137
static int error
Definition: plcont.c:61
static const char * script
Definition: tkMain.c:133
EXTERN int Itk_Init _ANSI_ARGS_((Tcl_Interp *interp))
static int synchronize
Definition: tkMain.c:132
static const char * fileName
Definition: tkMain.c:134
static PLINT * buffer
Definition: plfill.c:74
static char buf[200]
Definition: tclAPI.c:873
static int AppInit(Tcl_Interp *interp)
Definition: pltcl.c:134
#define PL_UNUSED(x)
Definition: plplot.h:138
static Tcl_DString command
Definition: tkMain.c:121
static Tk_ArgvInfo argTable[]
Definition: tkMain.c:139
static void Prompt(Tcl_Interp *interploc, int partial)
Definition: tkMain.c:600
#define BUFFER_SIZE
static const char * display
Definition: tkMain.c:136
static void StdinProc(ClientData PL_UNUSED(clientData), int PL_UNUSED(mask))
Definition: tkMain.c:494
static Tcl_Interp * interp
Definition: tkMain.c:120