• Main Page
  • Namespaces
  • Classes
  • Files
  • File List
  • File Members

tclMain.c

Go to the documentation of this file.
00001 // $Id: tclMain.c 11680 2011-03-27 17:57:51Z airwin $
00002 //
00003 // Modified version of tclMain.c, from Tcl 8.3.2.
00004 // Maurice LeBrun
00005 // Jan 2 2001
00006 //
00007 // Copyright (C) 2004  Joao Cardoso
00008 //
00009 // This file is part of PLplot.
00010 //
00011 // PLplot is free software; you can redistribute it and/or modify
00012 // it under the terms of the GNU Library General Public License as published
00013 // by the Free Software Foundation; either version 2 of the License, or
00014 // (at your option) any later version.
00015 //
00016 // PLplot is distributed in the hope that it will be useful,
00017 // but WITHOUT ANY WARRANTY; without even the implied warranty of
00018 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00019 // GNU Library General Public License for more details.
00020 //
00021 // You should have received a copy of the GNU Library General Public License
00022 // along with PLplot; if not, write to the Free Software
00023 // Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
00024 //
00025 //
00026 // Based on previous version of tclMain.c, from Tcl 7.3.
00027 // Modifications include:
00028 // 1. Tcl_Main() changed to pltclMain().
00029 // 2. Changes to work with ANSI C
00030 // 3. Changes to support user-installable error or output handlers.
00031 // 4. PLplot argument parsing routine called to handle arguments.
00032 // 5. Added define of _POSIX_SOURCE and eliminated include of tclInt.h.
00033 //
00034 // Original comments follow.
00035 //
00036 
00037 //
00038 // tclMain.c --
00039 //
00040 //      Main program for Tcl shells and other Tcl-based applications.
00041 //
00042 // Copyright (c) 1988-1994 The Regents of the University of California.
00043 // Copyright (c) 1994-1997 Sun Microsystems, Inc.
00044 //
00045 // See the file "license.terms" for information on usage and redistribution
00046 // of this file, and for a DISCLAIMER OF ALL WARRANTIES.
00047 //
00048 // RCS: @(#) $Id: tclMain.c 11680 2011-03-27 17:57:51Z airwin $
00049 //
00050 
00051 #include <tcl.h>
00052 #include "plplot.h"
00053 
00054 #if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 5
00055 // From (private) tclInt.h in tcl8.5
00056 #define TclFormatInt( buf, n )    sprintf( ( buf ), "%ld", (long) ( n ) )
00057 #else
00058 // From (private) tclIntDecls.h in tcl8.4 and before
00059 EXTERN int TclFormatInt _ANSI_ARGS_( ( char * buffer, long n ) );
00060 #endif
00061 
00062 #ifndef TclObjCommandComplete_TCL_DECLARED
00063 EXTERN int TclObjCommandComplete _ANSI_ARGS_( ( Tcl_Obj * cmdPtr ) );
00064 #endif
00065 
00066 # undef TCL_STORAGE_CLASS
00067 # define TCL_STORAGE_CLASS    DLLEXPORT
00068 
00069 //
00070 // The following code ensures that tclLink.c is linked whenever
00071 // Tcl is linked.  Without this code there's no reference to the
00072 // code in that file from anywhere in Tcl, so it may not be
00073 // linked into the application.
00074 //
00075 
00076 EXTERN int Tcl_LinkVar();
00077 int ( *tclDummyLinkVarPtr )() = Tcl_LinkVar;
00078 
00079 //
00080 // Declarations for various library procedures and variables (don't want
00081 // to include tclPort.h here, because people might copy this file out of
00082 // the Tcl source directory to make their own modified versions).
00083 // Note:  "exit" should really be declared here, but there's no way to
00084 // declare it without causing conflicts with other definitions elsewher
00085 // on some systems, so it's better just to leave it out.
00086 //
00087 
00088 extern int isatty _ANSI_ARGS_( (int fd) );
00089 extern char *           strcpy _ANSI_ARGS_( ( char *dst, CONST char *src ) );
00090 
00091 static const char *tclStartupScriptFileName = NULL;
00092 
00093 // pltcl enhancements
00094 
00095 static void
00096 plPrepOutputHandler( Tcl_Interp *interp, int code, int tty );
00097 
00098 // These are globally visible and can be replaced
00099 
00100 void ( *tclErrorHandler )( Tcl_Interp *interp, int code, int tty ) = NULL;
00101 
00102 void ( *tclPrepOutputHandler )( Tcl_Interp *interp, int code, int tty )
00103     = plPrepOutputHandler;
00104 
00105 // Options data structure definition.
00106 
00107 static char          *tclStartupScript = NULL;
00108 static const char    *pltcl_notes[]    = {
00109     "Specifying the filename on the command line is compatible with modern",
00110     "tclsh syntax.  Old tclsh's used the -f syntax, which is still supported.",
00111     "You may use either syntax but not both.",
00112     NULL
00113 };
00114 
00115 static PLOptionTable options[] = {
00116     {
00117         "f",                    // File to read & process
00118         NULL,
00119         NULL,
00120         &tclStartupScriptFileName,
00121         PL_OPT_STRING,
00122         "-f",
00123         "File from which to read commands"
00124     },
00125     {
00126         "file",                 // File to read & process (alias)
00127         NULL,
00128         NULL,
00129         &tclStartupScriptFileName,
00130         PL_OPT_STRING | PL_OPT_INVISIBLE,
00131         "-file",
00132         "File from which to read commands"
00133     },
00134     {
00135         "e",                    // Script to run on startup
00136         NULL,
00137         NULL,
00138         &tclStartupScript,
00139         PL_OPT_STRING,
00140         "-e",
00141         "Script to execute on startup"
00142     },
00143     {
00144         NULL,                   // option
00145         NULL,                   // handler
00146         NULL,                   // client data
00147         NULL,                   // address of variable to set
00148         0,                      // mode flag
00149         NULL,                   // short syntax
00150         NULL
00151     }                           // long syntax
00152 };
00153 
00154 
00155 //
00156 //--------------------------------------------------------------------------
00157 //
00158 // TclSetStartupScriptFileName --
00159 //
00160 //      Primes the startup script file name, used to override the
00161 //      command line processing.
00162 //
00163 // Results:
00164 //      None.
00165 //
00166 // Side effects:
00167 //      This procedure initializes the file name of the Tcl script to
00168 //      run at startup.
00169 //
00170 //--------------------------------------------------------------------------
00171 //
00172 void TclSetStartupScriptFileName( char *fileName )
00173 {
00174     tclStartupScriptFileName = fileName;
00175 }
00176 
00177 
00178 //
00179 //--------------------------------------------------------------------------
00180 //
00181 // TclGetStartupScriptFileName --
00182 //
00183 //      Gets the startup script file name, used to override the
00184 //      command line processing.
00185 //
00186 // Results:
00187 //      The startup script file name, NULL if none has been set.
00188 //
00189 // Side effects:
00190 //      None.
00191 //
00192 //--------------------------------------------------------------------------
00193 //
00194 const char *TclGetStartupScriptFileName( void )
00195 {
00196     return tclStartupScriptFileName;
00197 }
00198 
00199 
00200 
00201 //
00202 //--------------------------------------------------------------------------
00203 //
00204 // Tcl_Main --
00205 //
00206 //      Main program for tclsh and most other Tcl-based applications.
00207 //
00208 // Results:
00209 //      None. This procedure never returns (it exits the process when
00210 //      it's done.
00211 //
00212 // Side effects:
00213 //      This procedure initializes the Tcl world and then starts
00214 //      interpreting commands;  almost anything could happen, depending
00215 //      on the script being interpreted.
00216 //
00217 //--------------------------------------------------------------------------
00218 //
00219 
00220 int PLDLLEXPORT
00221 pltclMain( int argc, const char **argv, char *RcFileName /* OBSOLETE */,
00222            int ( *appInitProc )( Tcl_Interp *interp ) )
00223 {
00224     Tcl_Obj     *resultPtr;
00225     Tcl_Obj     *commandPtr = NULL;
00226     char        buffer[1000], *args;
00227     int         code, gotPartial, tty, length;
00228     int         exitCode = 0;
00229     Tcl_Channel inChannel, outChannel, errChannel;
00230     Tcl_Interp  *interp;
00231     Tcl_DString argString;
00232 
00233     char        usage[500];
00234 
00235     Tcl_FindExecutable( argv[0] );
00236     interp = Tcl_CreateInterp();
00237     Tcl_InitMemory( interp ); //no-op if TCL_MEM_DEBUG undefined
00238 
00239     // First process plplot-specific args using the PLplot parser.
00240 
00241     sprintf( usage, "\nUsage:\n        %s [filename] [options]\n", argv[0] );
00242     plSetUsage( NULL, usage );
00243     plMergeOpts( options, "pltcl options", pltcl_notes );
00244     (void) plparseopts( &argc, argv, PL_PARSE_FULL | PL_PARSE_SKIP );
00245 
00246     //
00247     // Make (remaining) command-line arguments available in the Tcl variables
00248     // "argc" and "argv".  If the first argument doesn't start with a "-" then
00249     // strip it off and use it as the name of a script file to process.
00250     //
00251 
00252     if ( tclStartupScriptFileName == NULL )
00253     {
00254         if ( ( argc > 1 ) && ( argv[1][0] != '-' ) )
00255         {
00256             tclStartupScriptFileName = argv[1];
00257             argc--;
00258             argv++;
00259         }
00260     }
00261     args = Tcl_Merge( argc - 1, ( CONST char * CONST * )argv + 1 );
00262     Tcl_ExternalToUtfDString( NULL, args, -1, &argString );
00263     Tcl_SetVar( interp, "argv", Tcl_DStringValue( &argString ), TCL_GLOBAL_ONLY );
00264     Tcl_DStringFree( &argString );
00265     ckfree( args );
00266 
00267     if ( tclStartupScriptFileName == NULL )
00268     {
00269         Tcl_ExternalToUtfDString( NULL, argv[0], -1, &argString );
00270     }
00271     else
00272     {
00273         tclStartupScriptFileName = Tcl_ExternalToUtfDString( NULL,
00274             tclStartupScriptFileName, -1, &argString );
00275     }
00276 
00277     TclFormatInt( buffer, argc - 1 );
00278     Tcl_SetVar( interp, "argc", buffer, TCL_GLOBAL_ONLY );
00279     Tcl_SetVar( interp, "argv0", Tcl_DStringValue( &argString ), TCL_GLOBAL_ONLY );
00280 
00281     //
00282     // Set the "tcl_interactive" variable.
00283     //
00284 
00285     tty = isatty( 0 );
00286     Tcl_SetVar( interp, "tcl_interactive",
00287         ( ( tclStartupScriptFileName == NULL ) && tty ) ? "1" : "0",
00288         TCL_GLOBAL_ONLY );
00289 
00290     //
00291     // Invoke application-specific initialization.
00292     //
00293 
00294     if ( ( *appInitProc )( interp ) != TCL_OK )
00295     {
00296         errChannel = Tcl_GetStdChannel( TCL_STDERR );
00297         if ( errChannel )
00298         {
00299             Tcl_WriteChars( errChannel,
00300                 "application-specific initialization failed: ", -1 );
00301             Tcl_WriteObj( errChannel, Tcl_GetObjResult( interp ) );
00302             Tcl_WriteChars( errChannel, "\n", 1 );
00303         }
00304     }
00305 
00306     //
00307     // Process the startup script, if any.
00308     //
00309 
00310     if ( tclStartupScript != NULL )
00311     {
00312         code = Tcl_VarEval( interp, tclStartupScript, (char *) NULL );
00313         if ( code != TCL_OK )
00314         {
00315             fprintf( stderr, "%s\n", Tcl_GetStringResult( interp ) );
00316             exitCode = 1;
00317         }
00318     }
00319 
00320     //
00321     // If a script file was specified then just source that file
00322     // and quit.
00323     //
00324 
00325     if ( tclStartupScriptFileName != NULL )
00326     {
00327         code = Tcl_EvalFile( interp, tclStartupScriptFileName );
00328         if ( code != TCL_OK )
00329         {
00330             errChannel = Tcl_GetStdChannel( TCL_STDERR );
00331             if ( errChannel )
00332             {
00333                 //
00334                 // The following statement guarantees that the errorInfo
00335                 // variable is set properly.
00336                 //
00337 
00338                 Tcl_AddErrorInfo( interp, "" );
00339                 Tcl_WriteObj( errChannel, Tcl_GetVar2Ex( interp, "errorInfo",
00340                         NULL, TCL_GLOBAL_ONLY ) );
00341                 Tcl_WriteChars( errChannel, "\n", 1 );
00342             }
00343             exitCode = 1;
00344         }
00345         goto done;
00346     }
00347     Tcl_DStringFree( &argString );
00348 
00349     //
00350     // We're running interactively.  Source a user-specific startup
00351     // file if the application specified one and if the file exists.
00352     //
00353 
00354     Tcl_SourceRCFile( interp );
00355 
00356     //
00357     // Process commands from stdin until there's an end-of-file.  Note
00358     // that we need to fetch the standard channels again after every
00359     // eval, since they may have been changed.
00360     //
00361 
00362     commandPtr = Tcl_NewObj();
00363     Tcl_IncrRefCount( commandPtr );
00364 
00365     inChannel  = Tcl_GetStdChannel( TCL_STDIN );
00366     outChannel = Tcl_GetStdChannel( TCL_STDOUT );
00367     gotPartial = 0;
00368     while ( 1 )
00369     {
00370         if ( tty )
00371         {
00372             Tcl_Obj *promptCmdPtr;
00373 
00374             promptCmdPtr = Tcl_GetVar2Ex( interp,
00375                 ( gotPartial ? "tcl_prompt2" : "tcl_prompt1" ),
00376                 NULL, TCL_GLOBAL_ONLY );
00377             if ( promptCmdPtr == NULL )
00378             {
00379 defaultPrompt:
00380                 if ( !gotPartial && outChannel )
00381                 {
00382                     Tcl_WriteChars( outChannel, "% ", 2 );
00383                 }
00384             }
00385             else
00386             {
00387                 code       = Tcl_EvalObjEx( interp, promptCmdPtr, 0 );
00388                 inChannel  = Tcl_GetStdChannel( TCL_STDIN );
00389                 outChannel = Tcl_GetStdChannel( TCL_STDOUT );
00390                 errChannel = Tcl_GetStdChannel( TCL_STDERR );
00391                 if ( code != TCL_OK )
00392                 {
00393                     if ( errChannel )
00394                     {
00395                         Tcl_WriteObj( errChannel, Tcl_GetObjResult( interp ) );
00396                         Tcl_WriteChars( errChannel, "\n", 1 );
00397                     }
00398                     Tcl_AddErrorInfo( interp,
00399                         "\n    (script that generates prompt)" );
00400                     goto defaultPrompt;
00401                 }
00402             }
00403             if ( outChannel )
00404             {
00405                 Tcl_Flush( outChannel );
00406             }
00407         }
00408         if ( !inChannel )
00409         {
00410             goto done;
00411         }
00412         length = Tcl_GetsObj( inChannel, commandPtr );
00413         if ( length < 0 )
00414         {
00415             goto done;
00416         }
00417         if ( ( length == 0 ) && Tcl_Eof( inChannel ) && ( !gotPartial ) )
00418         {
00419             goto done;
00420         }
00421 
00422         //
00423         // Add the newline removed by Tcl_GetsObj back to the string.
00424         //
00425 
00426         Tcl_AppendToObj( commandPtr, "\n", 1 );
00427         if ( !TclObjCommandComplete( commandPtr ) )
00428         {
00429             gotPartial = 1;
00430             continue;
00431         }
00432 
00433         gotPartial = 0;
00434         code       = Tcl_RecordAndEvalObj( interp, commandPtr, 0 );
00435         inChannel  = Tcl_GetStdChannel( TCL_STDIN );
00436         outChannel = Tcl_GetStdChannel( TCL_STDOUT );
00437         errChannel = Tcl_GetStdChannel( TCL_STDERR );
00438         Tcl_DecrRefCount( commandPtr );
00439         commandPtr = Tcl_NewObj();
00440         Tcl_IncrRefCount( commandPtr );
00441 
00442         // User defined function to deal with tcl command output
00443         // Deprecated; for backward compatibility only
00444         if ( ( ( code != TCL_OK ) || tty ) && tclErrorHandler )
00445             ( *tclErrorHandler )( interp, code, tty );
00446         else
00447         {
00448             // User defined function to prepare for tcl output
00449             // This is the new way
00450             if ( ( ( code != TCL_OK ) || tty ) && tclPrepOutputHandler )
00451                 ( *tclPrepOutputHandler )( interp, code, tty );
00452             // Back to the stock tcl code
00453             if ( code != TCL_OK )
00454             {
00455                 if ( errChannel )
00456                 {
00457                     Tcl_WriteObj( errChannel, Tcl_GetObjResult( interp ) );
00458                     Tcl_WriteChars( errChannel, "\n", 1 );
00459                 }
00460             }
00461             else if ( tty )
00462             {
00463                 resultPtr = Tcl_GetObjResult( interp );
00464                 Tcl_GetStringFromObj( resultPtr, &length );
00465                 if ( ( length > 0 ) && outChannel )
00466                 {
00467                     Tcl_WriteObj( outChannel, resultPtr );
00468                     Tcl_WriteChars( outChannel, "\n", 1 );
00469                 }
00470             }
00471         }
00472     }
00473 
00474     //
00475     // Rather than calling exit, invoke the "exit" command so that
00476     // users can replace "exit" with some other command to do additional
00477     // cleanup on exit.  The Tcl_Eval call should never return.
00478     //
00479 
00480 done:
00481     if ( commandPtr != NULL )
00482     {
00483         Tcl_DecrRefCount( commandPtr );
00484     }
00485     sprintf( buffer, "exit %d", exitCode );
00486     Tcl_Eval( interp, buffer );
00487     return 0;           // to silence warnings
00488 }
00489 
00490 //
00491 //--------------------------------------------------------------------------
00492 //
00493 // plPrepOutputHandler --
00494 //
00495 //      Prepares for output during command parsing.  We use it here to
00496 //      ensure we are on the text screen before issuing the error message,
00497 //      otherwise it may disappear.
00498 //
00499 // Results:
00500 //      None.
00501 //
00502 // Side effects:
00503 //      For some graphics devices, a switch between graphics and text modes
00504 //      is done.
00505 //
00506 //--------------------------------------------------------------------------
00507 //
00508 
00509 static void
00510 plPrepOutputHandler( Tcl_Interp *interp, int code, int tty )
00511 {
00512     pltext();
00513 }

Generated on Wed Oct 12 2011 20:42:23 for PLplot by  doxygen 1.7.1