tclMain.c

Go to the documentation of this file.

// Modified version of tclMain.c, from Tcl 8.3.2.
// Maurice LeBrun
// Jan 2 2001
//
// Copyright (C) 2004  Joao Cardoso
//
// This file is part of PLplot.
//
// PLplot is free software; you can redistribute it and/or modify
// it under the terms of the GNU Library General Public License as published
// by the Free Software Foundation; either version 2 of the License, or
// (at your option) any later version.
//
// PLplot is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU Library General Public License for more details.
//
// You should have received a copy of the GNU Library General Public License
// along with PLplot; if not, write to the Free Software
// Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
//
//
// Based on previous version of tclMain.c, from Tcl 7.3.
// Modifications include:
// 1. Tcl_Main() changed to pltclMain().
// 2. Changes to work with ANSI C
// 3. Changes to support user-installable error or output handlers.
// 4. PLplot argument parsing routine called to handle arguments.
// 5. Added define of _POSIX_SOURCE and eliminated include of tclInt.h.
//
// Original comments follow.
//
 
//
// tclMain.c --
//
//      Main program for Tcl shells and other Tcl-based applications.
//
// Copyright (c) 1988-1994 The Regents of the University of California.
// Copyright (c) 1994-1997 Sun Microsystems, Inc.
//
// See the file "license.terms" for information on usage and redistribution
// of this file, and for a DISCLAIMER OF ALL WARRANTIES.
//
 
#include "pltcl.h"
// Required for definition of PL_UNUSED macro
#include "plplotP.h"
 
#if defined( TCL_MAJOR_VERSION ) && TCL_MAJOR_VERSION >= 9
/* Tcl 9 provides Tcl_Size directly. */
#else
typedef int Tcl_Size;
#endif
 
#define TclFormatInt( buf, n )    sprintf( ( buf ), "%ld", (long) ( n ) )
 
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS    DLLEXPORT
 
//
// The following code ensures that tclLink.c is linked whenever
// Tcl is linked.  Without this code there's no reference to the
// code in that file from anywhere in Tcl, so it may not be
// linked into the application.
//
 
// Experiments show this is no longer required, and in any case
// it screws up using the Tcl stub library. So comment out (AWI).
//EXTERN int Tcl_LinkVar( );
//int ( *tclDummyLinkVarPtr )() = Tcl_LinkVar;
 
//
// Declarations for various library procedures and variables (don't want
// to include tclPort.h here, because people might copy this file out of
// the Tcl source directory to make their own modified versions).
// Note:  "exit" should really be declared here, but there's no way to
// declare it without causing conflicts with other definitions elsewher
// on some systems, so it's better just to leave it out.
//
 
extern int isatty ( int fd );
extern char *           strcpy ( char *dst, const char *src );
 
static const char *tclStartupScriptFileName = NULL;
 
// pltcl enhancements
 
static void
plPrepOutputHandler( Tcl_Interp *interp, int code, int tty );
 
// Other function prototypes
void TclSetStartupScriptFileName( char *fileName );
const char *TclGetStartupScriptFileName( void );
 
// These are globally visible and can be replaced
 
void ( *tclErrorHandler )( Tcl_Interp *interp, int code, int tty ) = NULL;
 
void ( *tclPrepOutputHandler )( Tcl_Interp *interp, int code, int tty )
    = plPrepOutputHandler;
 
// Options data structure definition.
 
static char          *tclStartupScript = NULL;
static const char    *pltcl_notes[]    = {
    "Specifying the filename on the command line is compatible with modern",
    "tclsh syntax.  Old tclsh's used the -f syntax, which is still supported.",
    "You may use either syntax but not both.",
    NULL
};
 
static PLOptionTable options[] = {
    {
        "f",                    // File to read & process
        NULL,
        NULL,
        &tclStartupScriptFileName,
        PL_OPT_STRING,
        "-f",
        "File from which to read commands"
    },
    {
        "file",                 // File to read & process (alias)
        NULL,
        NULL,
        &tclStartupScriptFileName,
        PL_OPT_STRING | PL_OPT_INVISIBLE,
        "-file",
        "File from which to read commands"
    },
    {
        "e",                    // Script to run on startup
        NULL,
        NULL,
        &tclStartupScript,
        PL_OPT_STRING,
        "-e",
        "Script to execute on startup"
    },
    {
        NULL,                   // option
        NULL,                   // handler
        NULL,                   // client data
        NULL,                   // address of variable to set
        0,                      // mode flag
        NULL,                   // short syntax
        NULL
    }                           // long syntax
};
 
 
//
//--------------------------------------------------------------------------
//
// TclSetStartupScriptFileName --
//
//      Primes the startup script file name, used to override the
//      command line processing.
//
// Results:
//      None.
//
// Side effects:
//      This procedure initializes the file name of the Tcl script to
//      run at startup.
//
//--------------------------------------------------------------------------
//
void TclSetStartupScriptFileName( char *fileName )
{
    tclStartupScriptFileName = fileName;
}
 
 
//
//--------------------------------------------------------------------------
//
// TclGetStartupScriptFileName --
//
//      Gets the startup script file name, used to override the
//      command line processing.
//
// Results:
//      The startup script file name, NULL if none has been set.
//
// Side effects:
//      None.
//
//--------------------------------------------------------------------------
//
const char *TclGetStartupScriptFileName( void )
{
    return tclStartupScriptFileName;
}
 
 
 
//
//--------------------------------------------------------------------------
//
// Tcl_Main --
//
//      Main program for tclsh and most other Tcl-based applications.
//
// Results:
//      None. This procedure never returns (it exits the process when
//      it's done.
//
// Side effects:
//      This procedure initializes the Tcl world and then starts
//      interpreting commands;  almost anything could happen, depending
//      on the script being interpreted.
//
//--------------------------------------------------------------------------
//
 
int PLDLLEXPORT
pltclMain( int argc, char **argv, char * PL_UNUSED( RcFileName ) /* OBSOLETE */,
           int ( *appInitProc )( Tcl_Interp *interp ) )
{
    Tcl_Obj     *resultPtr;
    Tcl_Obj     *commandPtr = NULL;
    char        buffer[1000], *args;
    int         code, gotPartial, tty;
    Tcl_Size    length;
    int         exitCode = 0;
    Tcl_Channel inChannel, outChannel, errChannel;
    Tcl_Interp  *interp;
    Tcl_DString argString;
 
    char        usage[500];
 
    Tcl_FindExecutable( argv[0] );
    interp = Tcl_CreateInterp();
    Tcl_InitMemory( interp ); //no-op if TCL_MEM_DEBUG undefined
 
    // First process plplot-specific args using the PLplot parser.
 
    sprintf( usage, "\nUsage:\n        %s [filename] [options]\n", argv[0] );
    plSetUsage( NULL, usage );
    plMergeOpts( options, "pltcl options", pltcl_notes );
    plparseopts( &argc, argv, PL_PARSE_FULL | PL_PARSE_SKIP );
 
    //
    // Make (remaining) command-line arguments available in the Tcl variables
    // "argc" and "argv".  If the first argument doesn't start with a "-" then
    // strip it off and use it as the name of a script file to process.
    //
 
    if ( tclStartupScriptFileName == NULL )
    {
        if ( ( argc > 1 ) && ( argv[1][0] != '-' ) )
        {
            tclStartupScriptFileName = argv[1];
            argc--;
            argv++;
        }
    }
    args = Tcl_Merge( argc - 1, ( const char * const * )argv + 1 );
    Tcl_ExternalToUtfDString( NULL, args, -1, &argString );
    Tcl_SetVar( interp, "argv", Tcl_DStringValue( &argString ), TCL_GLOBAL_ONLY );
    Tcl_DStringFree( &argString );
    ckfree( args );
 
    if ( tclStartupScriptFileName == NULL )
    {
        Tcl_ExternalToUtfDString( NULL, argv[0], -1, &argString );
    }
    else
    {
        tclStartupScriptFileName = Tcl_ExternalToUtfDString( NULL,
            tclStartupScriptFileName, -1, &argString );
    }
 
    TclFormatInt( buffer, argc - 1 );
    Tcl_SetVar( interp, "argc", buffer, TCL_GLOBAL_ONLY );
    Tcl_SetVar( interp, "argv0", Tcl_DStringValue( &argString ), TCL_GLOBAL_ONLY );
 
    //
    // Set the "tcl_interactive" variable.
    //
 
    tty = isatty( 0 );
    Tcl_SetVar( interp, "tcl_interactive",
        ( ( tclStartupScriptFileName == NULL ) && tty ) ? "1" : "0",
        TCL_GLOBAL_ONLY );
 
    //
    // Invoke application-specific initialization.
    //
 
    if ( ( *appInitProc )( interp ) != TCL_OK )
    {
        errChannel = Tcl_GetStdChannel( TCL_STDERR );
        if ( errChannel )
        {
            Tcl_WriteChars( errChannel,
                "application-specific initialization failed: ", -1 );
            Tcl_WriteObj( errChannel, Tcl_GetObjResult( interp ) );
            Tcl_WriteChars( errChannel, "\n", 1 );
        }
    }
 
    //
    // Process the startup script, if any.
    //
 
    if ( tclStartupScript != NULL )
    {
        code = Tcl_VarEval( interp, tclStartupScript, (char *) NULL );
        if ( code != TCL_OK )
        {
            fprintf( stderr, "%s\n", Tcl_GetStringResult( interp ) );
            exitCode = 1;
        }
    }
 
    //
    // If a script file was specified then just source that file
    // and quit.
    //
 
    if ( tclStartupScriptFileName != NULL )
    {
        code = Tcl_EvalFile( interp, tclStartupScriptFileName );
        if ( code != TCL_OK )
        {
            errChannel = Tcl_GetStdChannel( TCL_STDERR );
            if ( errChannel )
            {
                //
                // The following statement guarantees that the errorInfo
                // variable is set properly.
                //
 
                Tcl_AddErrorInfo( interp, "" );
                Tcl_WriteObj( errChannel, Tcl_GetVar2Ex( interp, "errorInfo",
                        NULL, TCL_GLOBAL_ONLY ) );
                Tcl_WriteChars( errChannel, "\n", 1 );
            }
            exitCode = 1;
        }
        goto done;
    }
    Tcl_DStringFree( &argString );
 
    //
    // We're running interactively.  Source a user-specific startup
    // file if the application specified one and if the file exists.
    //
 
    Tcl_SourceRCFile( interp );
 
    //
    // Process commands from stdin until there's an end-of-file.  Note
    // that we need to fetch the standard channels again after every
    // eval, since they may have been changed.
    //
 
    commandPtr = Tcl_NewObj();
    Tcl_IncrRefCount( commandPtr );
 
    inChannel  = Tcl_GetStdChannel( TCL_STDIN );
    outChannel = Tcl_GetStdChannel( TCL_STDOUT );
    gotPartial = 0;
    while ( 1 )
    {
        if ( tty )
        {
            Tcl_Obj *promptCmdPtr;
 
            promptCmdPtr = Tcl_GetVar2Ex( interp,
                ( gotPartial ? "tcl_prompt2" : "tcl_prompt1" ),
                NULL, TCL_GLOBAL_ONLY );
            if ( promptCmdPtr == NULL )
            {
defaultPrompt:
                if ( !gotPartial && outChannel )
                {
                    Tcl_WriteChars( outChannel, "% ", 2 );
                }
            }
            else
            {
                code       = Tcl_EvalObjEx( interp, promptCmdPtr, 0 );
                inChannel  = Tcl_GetStdChannel( TCL_STDIN );
                outChannel = Tcl_GetStdChannel( TCL_STDOUT );
                errChannel = Tcl_GetStdChannel( TCL_STDERR );
                if ( code != TCL_OK )
                {
                    if ( errChannel )
                    {
                        Tcl_WriteObj( errChannel, Tcl_GetObjResult( interp ) );
                        Tcl_WriteChars( errChannel, "\n", 1 );
                    }
                    Tcl_AddErrorInfo( interp,
                        "\n    (script that generates prompt)" );
                    goto defaultPrompt;
                }
            }
            if ( outChannel )
            {
                Tcl_Flush( outChannel );
            }
        }
        if ( !inChannel )
        {
            goto done;
        }
        length = Tcl_GetsObj( inChannel, commandPtr );
        if ( length < 0 )
        {
            goto done;
        }
        if ( ( length == 0 ) && Tcl_Eof( inChannel ) && ( !gotPartial ) )
        {
            goto done;
        }
 
        //
        // Add the newline removed by Tcl_GetsObj back to the string.
        //
 
        Tcl_AppendToObj( commandPtr, "\n", 1 );
        if ( !Tcl_CommandComplete( Tcl_GetString( commandPtr ) ) )
        {
            gotPartial = 1;
            continue;
        }
 
        gotPartial = 0;
        code       = Tcl_RecordAndEvalObj( interp, commandPtr, 0 );
        inChannel  = Tcl_GetStdChannel( TCL_STDIN );
        outChannel = Tcl_GetStdChannel( TCL_STDOUT );
        errChannel = Tcl_GetStdChannel( TCL_STDERR );
        Tcl_DecrRefCount( commandPtr );
        commandPtr = Tcl_NewObj();
        Tcl_IncrRefCount( commandPtr );
 
        // User defined function to deal with tcl command output
        // Deprecated; for backward compatibility only
        if ( ( ( code != TCL_OK ) || tty ) && tclErrorHandler )
            ( *tclErrorHandler )( interp, code, tty );
        else
        {
            // User defined function to prepare for tcl output
            // This is the new way
            if ( ( ( code != TCL_OK ) || tty ) && tclPrepOutputHandler )
                ( *tclPrepOutputHandler )( interp, code, tty );
            // Back to the stock tcl code
            if ( code != TCL_OK )
            {
                if ( errChannel )
                {
                    Tcl_WriteObj( errChannel, Tcl_GetObjResult( interp ) );
                    Tcl_WriteChars( errChannel, "\n", 1 );
                }
            }
            else if ( tty )
            {
                resultPtr = Tcl_GetObjResult( interp );
                Tcl_GetStringFromObj( resultPtr, &length );
                if ( ( length > 0 ) && outChannel )
                {
                    Tcl_WriteObj( outChannel, resultPtr );
                    Tcl_WriteChars( outChannel, "\n", 1 );
                }
            }
        }
    }
 
    //
    // Rather than calling exit, invoke the "exit" command so that
    // users can replace "exit" with some other command to do additional
    // cleanup on exit.  The Tcl_Eval call should never return.
    //
 
done:
    if ( commandPtr != NULL )
    {
        Tcl_DecrRefCount( commandPtr );
    }
    sprintf( buffer, "exit %d", exitCode );
    Tcl_Eval( interp, buffer );
    return 0;           // to silence warnings
}
 
//
//--------------------------------------------------------------------------
//
// plPrepOutputHandler --
//
//      Prepares for output during command parsing.  We use it here to
//      ensure we are on the text screen before issuing the error message,
//      otherwise it may disappear.
//
// Results:
//      None.
//
// Side effects:
//      For some graphics devices, a switch between graphics and text modes
//      is done.
//
//--------------------------------------------------------------------------
//
 
static void
plPrepOutputHandler( Tcl_Interp *PL_UNUSED( interp ), int PL_UNUSED( code ), int PL_UNUSED( tty ) )
{
    pltext();
}