mirror of
https://github.com/envmodules/modules.git
synced 2026-06-10 00:56:30 +08:00
b3c7011933
* Changed the configure to search for libTcl.sh to acquire all it's necessary Tcl env.vars from it. * created a utility function stringer() to handle most of the strcpy/strcat operations and to automatically allocate string memory. * Mostly changed the memory malloc/free to use stringer/null_free. * rewrote some of the code logic to have a single point of exit with unwinding of memory allocations.
869 lines
25 KiB
C
869 lines
25 KiB
C
/*****
|
||
** ** Module Header ******************************************************* **
|
||
** **
|
||
** Modules Revision 3.0 **
|
||
** Providing a flexible user environment **
|
||
** **
|
||
** File: cmdModule.c **
|
||
** First Edition: 91/10/23 **
|
||
** **
|
||
** Authors: John Furlan, jlf@behere.com **
|
||
** Jens Hamisch, jens@Strawberry.COM **
|
||
** **
|
||
** Description: The actual module command from the Tcl level. This **
|
||
** routines calls other ModuleCmd routines to carry out **
|
||
** the subcommand requested. **
|
||
** **
|
||
** Exports: cmdModule **
|
||
** Read_Modulefile **
|
||
** Execute_TclFile **
|
||
** CallModuleProcedure **
|
||
** **
|
||
** Notes: **
|
||
** **
|
||
** ************************************************************************ **
|
||
****/
|
||
|
||
/** ** Copyright *********************************************************** **
|
||
** **
|
||
** Copyright 1991-1994 by John L. Furlan. **
|
||
** see LICENSE.GPL, which must be provided, for details **
|
||
** **
|
||
** ************************************************************************ **/
|
||
|
||
static char Id[] = "@(#)$Id: cmdModule.c,v 1.7 2002/04/29 21:16:48 rkowen Exp $";
|
||
static void *UseId[] = { &UseId, Id };
|
||
|
||
/** ************************************************************************ **/
|
||
/** HEADERS **/
|
||
/** ************************************************************************ **/
|
||
|
||
#include "modules_def.h"
|
||
|
||
/** ************************************************************************ **/
|
||
/** LOCAL DATATYPES **/
|
||
/** ************************************************************************ **/
|
||
|
||
/** not applicable **/
|
||
|
||
/** ************************************************************************ **/
|
||
/** CONSTANTS **/
|
||
/** ************************************************************************ **/
|
||
|
||
/** not applicable **/
|
||
|
||
/** ************************************************************************ **/
|
||
/** MACROS **/
|
||
/** ************************************************************************ **/
|
||
|
||
/** not applicable **/
|
||
|
||
/** ************************************************************************ **/
|
||
/** LOCAL DATA **/
|
||
/** ************************************************************************ **/
|
||
|
||
char _fil_stdin[] = "stdin";
|
||
char _fil_stdout[] = "stdout";
|
||
char _fil_stderr[] = "stderr";
|
||
char _fil_devnull[] = "/dev/null";
|
||
|
||
int linenum = 0;
|
||
|
||
static char module_name[] = "cmdModule.c"; /** File name of this module **/
|
||
|
||
#if WITH_DEBUGGING_CALLBACK
|
||
static char _proc_cmdModule[] = "cmdModule";
|
||
#endif
|
||
#if WITH_DEBUGGING_UTIL
|
||
static char _proc_Read_Modulefile[] = "Read_Modulefile";
|
||
#endif
|
||
#if WITH_DEBUGGING_UTIL_1
|
||
static char _proc_Execute_TclFile[] = "Execute_TclFile";
|
||
static char _proc_CallModuleProcedure[] = "CallModuleProcedure";
|
||
#endif
|
||
|
||
char *module_command;
|
||
|
||
/** ************************************************************************ **/
|
||
/** PROTOTYPES **/
|
||
/** ************************************************************************ **/
|
||
|
||
/** not applicable **/
|
||
|
||
|
||
/*++++
|
||
** ** Function-Header ***************************************************** **
|
||
** **
|
||
** Function: cmdModule **
|
||
** **
|
||
** Description: Evaluation of the module command line and callup of **
|
||
** the according subroutine **
|
||
** **
|
||
** First Edition: 91/10/23 **
|
||
** **
|
||
** Parameters: ClientData client_data **
|
||
** Tcl_Interp *interp According Tcl interp.**
|
||
** int argc Number of arguments **
|
||
** char *argv[] Argument array **
|
||
** **
|
||
** Result: int TCL_OK Successfull completion **
|
||
** TCL_ERROR Any error **
|
||
** **
|
||
** Attached Globals: g_flags These are set up accordingly before **
|
||
** this function is called in order to **
|
||
** control everything **
|
||
** g_current_module The module which is handled **
|
||
** by the current command **
|
||
** **
|
||
** ************************************************************************ **
|
||
++++*/
|
||
|
||
int cmdModule( ClientData client_data,
|
||
Tcl_Interp *interp,
|
||
int argc,
|
||
char *argv[])
|
||
{
|
||
int return_val = -1, i;
|
||
int store_flags = g_flags;
|
||
char *store_curmodule = NULL;
|
||
char *save_module_command = NULL;
|
||
#ifdef FORCE_PATH
|
||
char *base_path = NULL;
|
||
char *sacred_path = NULL;
|
||
#endif
|
||
int match = 0;
|
||
|
||
/**
|
||
** These skip the arguments past the shell and command.
|
||
**/
|
||
|
||
int num_modulefiles = argc - 2;
|
||
char **modulefile_list = argv + 2;
|
||
|
||
#if 0
|
||
int x=0;
|
||
# define _XD fprintf(stderr,":%d:",++x),
|
||
#else
|
||
# define _XD
|
||
#endif
|
||
|
||
#define _MTCH _XD match =
|
||
#define _ISERR ((match == -1) && (*interp->result))
|
||
|
||
#if WITH_DEBUGGING_CALLBACK
|
||
ErrorLogger( NO_ERR_START, LOC, _proc_cmdModule, NULL);
|
||
#endif
|
||
|
||
/**
|
||
** Help or whatis mode?
|
||
**/
|
||
|
||
if( g_flags & (M_HELP | M_WHATIS))
|
||
return( TCL_OK);
|
||
|
||
/**
|
||
** Parameter check
|
||
**/
|
||
|
||
if( argc < 2) {
|
||
(void) ErrorLogger( ERR_USAGE, LOC, "module", " command ",
|
||
" [arguments ...] ", NULL);
|
||
(void) ModuleCmd_Help( interp, 0, modulefile_list);
|
||
return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
|
||
}
|
||
|
||
/**
|
||
** Display whatis mode?
|
||
**/
|
||
|
||
if( g_flags & M_DISPLAY) {
|
||
fprintf( stderr, "%s\t\t ", argv[ 0]);
|
||
for( i=1; i<argc; i++)
|
||
fprintf( stderr, "%s ", argv[ i]);
|
||
fprintf( stderr, "\n");
|
||
return( TCL_OK);
|
||
}
|
||
|
||
/**
|
||
** For recursion. This can be called multiple times.
|
||
**/
|
||
|
||
save_module_command = module_command;
|
||
module_command = strdup( argv[1]);
|
||
|
||
if( g_current_module)
|
||
store_curmodule = g_current_module;
|
||
|
||
/**
|
||
** If the command is '-', we want to just start
|
||
** interpreting Tcl from stdin.
|
||
**/
|
||
|
||
if(_XD !strcmp( module_command, "-")) {
|
||
return_val = Execute_TclFile( interp, _fil_stdin);
|
||
|
||
/**
|
||
** Evaluate the module command and call the according subroutine
|
||
** --- module LOAD|ADD
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command, addRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_Load( interp, 1,num_modulefiles,modulefile_list);
|
||
|
||
#ifdef FORCE_PATH
|
||
if( return_val) {
|
||
|
||
/**
|
||
** return_val now indicates whether ANY modulefile was loaded
|
||
** Only if any modulefile was loaded do we need to worry
|
||
** about forcing paths.
|
||
**/
|
||
|
||
if( base_path = (char *) getenv( "MODULES_PATH_BASE") ||
|
||
base_path = (char *) getenv( "BASE_PATH")) {
|
||
ForceBasePath( interp, "PATH", base_path);
|
||
} else {
|
||
ForceBasePath( interp, "PATH", FORCE_PATH);
|
||
}
|
||
|
||
if( sacred_path = (char *) getenv( "MODULES_PATH_SACRED") ||
|
||
sacred_path = (char *) getenv( "SACRED_PATH")) {
|
||
ForceSacredPath( interp, "PATH", sacred_path);
|
||
} else {
|
||
ForceSacredPath( interp, "PATH", FORCE_PATH_SACRED);
|
||
}
|
||
|
||
if(sacred_path = (char *) getenv("MODULES_LD_LIBRARY_PATH_SACRED")){
|
||
ForceSacredPath( interp, "LD_LIBRARY_PATH", sacred_path);
|
||
} else {
|
||
ForceSacredPath( interp, "LD_LIBRARY_PATH",
|
||
FORCE_LD_LIBRARY_PATH_SACRED);
|
||
}
|
||
|
||
} /** if( return_val) **/
|
||
#endif
|
||
|
||
/**
|
||
** We always say the load succeeded. ModuleCmd_Load will
|
||
** output any necessary error messages.
|
||
**/
|
||
|
||
return_val = TCL_OK;
|
||
|
||
/**
|
||
** --- module UNLOAD
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command, rmRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
ModuleCmd_Load( interp, 0, num_modulefiles, modulefile_list);
|
||
return_val = TCL_OK;
|
||
|
||
/**
|
||
** --- module SWITCH
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command, swRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_Switch( interp, num_modulefiles,modulefile_list);
|
||
|
||
/**
|
||
** --- module DISPLAY
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command, dispRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_Display( interp,num_modulefiles,modulefile_list);
|
||
|
||
/**
|
||
** --- module LIST
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command, listRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
if (! (sw_format & SW_SET) ) { /* default format options */
|
||
sw_format |= (SW_HUMAN | SW_TERSE );
|
||
sw_format &= ~(SW_PARSE | SW_LONG );
|
||
}
|
||
/* use SW_LIST to indicate LIST & not AVAIL */
|
||
sw_format |= SW_LIST;
|
||
return_val = ModuleCmd_List( interp, num_modulefiles, modulefile_list);
|
||
|
||
/**
|
||
** --- module AVAIL
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command,availRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
if (! (sw_format & SW_SET) ) { /* default format options */
|
||
sw_format |= (SW_HUMAN | SW_TERSE);
|
||
sw_format &= ~(SW_PARSE | SW_LONG );
|
||
}
|
||
/* use SW_LIST to indicate LIST & not AVAIL */
|
||
sw_format &= ~SW_LIST;
|
||
return_val = ModuleCmd_Avail( interp, num_modulefiles, modulefile_list);
|
||
|
||
/**
|
||
** --- module WHATIS and APROPOS
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command,whatisRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_Whatis(interp, num_modulefiles, modulefile_list);
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command,aproposRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_Apropos(interp, num_modulefiles,modulefile_list);
|
||
|
||
/**
|
||
** --- module CLEAR
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command,clearRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_Clear( interp, num_modulefiles, modulefile_list);
|
||
|
||
/**
|
||
** --- module UPDATE
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command,updateRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_Update(interp, num_modulefiles, modulefile_list);
|
||
|
||
/**
|
||
** --- module PURGE
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command,purgeRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_Purge( interp, num_modulefiles, modulefile_list);
|
||
|
||
/**
|
||
** --- module INIT
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command,initRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
|
||
if( Tcl_RegExpMatch(interp,module_command, "^inita|^ia")){/* initadd */
|
||
if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
|
||
g_flags |= M_LOAD;
|
||
return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
|
||
g_flags &= ~M_LOAD;
|
||
}
|
||
|
||
if( Tcl_RegExpMatch(interp,module_command, "^initr|^iw")){ /* initrm */
|
||
if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
|
||
g_flags |= M_REMOVE;
|
||
return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
|
||
g_flags &= ~M_REMOVE;
|
||
}
|
||
|
||
if( Tcl_RegExpMatch(interp,module_command, "^initl|^il")){/* initlist*/
|
||
if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
|
||
g_flags |= M_DISPLAY;
|
||
return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
|
||
g_flags &= ~M_DISPLAY;
|
||
}
|
||
|
||
if(Tcl_RegExpMatch(interp,module_command, "^inits|^is")){/* initswitch*/
|
||
if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
|
||
g_flags |= M_SWITCH;
|
||
return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
|
||
g_flags &= ~M_SWITCH;
|
||
}
|
||
|
||
if(Tcl_RegExpMatch(interp,module_command, "^initc|^ic")){/* initclear*/
|
||
if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
|
||
g_flags |= M_CLEAR;
|
||
return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
|
||
g_flags &= ~M_CLEAR;
|
||
}
|
||
|
||
if(Tcl_RegExpMatch(interp,module_command,"^initp|^ip")){/*initprepend*/
|
||
if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
|
||
g_flags |= (M_PREPEND | M_LOAD);
|
||
return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
|
||
g_flags &= ~(M_PREPEND | M_LOAD);
|
||
}
|
||
|
||
/**
|
||
** --- module USE
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command, useRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_Use( interp, num_modulefiles, modulefile_list);
|
||
|
||
/**
|
||
** --- module UNUSE
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command, unuseRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_UnUse( interp, num_modulefiles, modulefile_list);
|
||
|
||
/**
|
||
** --- module HELP
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command, helpRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_Help( interp, num_modulefiles, modulefile_list);
|
||
/**
|
||
** --- module bootstrap
|
||
**/
|
||
|
||
} else if(_MTCH Tcl_RegExpMatch(interp,module_command, bootstrapRE)) {
|
||
if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
|
||
return_val = ModuleCmd_Bootstrap( interp, num_modulefiles, modulefile_list);
|
||
}
|
||
|
||
/**
|
||
** Tracing
|
||
**/
|
||
|
||
if( CheckTracingList(interp, module_command,
|
||
num_modulefiles, modulefile_list))
|
||
Module_Tracing( return_val, argc, argv);
|
||
|
||
/**
|
||
** Evaluate the subcommands return value in order to get rid of unrecog-
|
||
** nized commands
|
||
**/
|
||
|
||
if( return_val < 0)
|
||
if( OK != ErrorLogger( ERR_COMMAND, LOC, module_command, NULL))
|
||
return (TCL_ERROR);
|
||
|
||
/**
|
||
** Clean up from recursion
|
||
**/
|
||
|
||
g_flags = store_flags;
|
||
if( store_curmodule)
|
||
g_current_module = store_curmodule;
|
||
|
||
module_command = save_module_command;
|
||
|
||
/**
|
||
** Return on success
|
||
**/
|
||
|
||
#if WITH_DEBUGGING_CALLBACK
|
||
ErrorLogger( NO_ERR_END, LOC, _proc_cmdModule, NULL);
|
||
#endif
|
||
|
||
return( return_val);
|
||
|
||
} /** End of 'cmdModule' **/
|
||
|
||
/*++++
|
||
** ** Function-Header ***************************************************** **
|
||
** **
|
||
** Function: Read_Modulefile **
|
||
** **
|
||
** Description: Check the passed filename for to be a valid module **
|
||
** and execute the according command file **
|
||
** **
|
||
** First Edition: 91/10/23 **
|
||
** **
|
||
** Parameters: Tcl_Interp *interp According Tcl interp.**
|
||
** char *filename **
|
||
** **
|
||
** Result: int TCL_OK Successfull completion **
|
||
** TCL_ERROR Any error **
|
||
** **
|
||
** Attached Globals: **
|
||
** **
|
||
** ************************************************************************ **
|
||
++++*/
|
||
|
||
int Read_Modulefile( Tcl_Interp *interp,
|
||
char *filename)
|
||
{
|
||
int result;
|
||
char *startp, *endp;
|
||
|
||
#if WITH_DEBUGGING_UTIL
|
||
ErrorLogger( NO_ERR_START, LOC, _proc_Read_Modulefile, NULL);
|
||
#endif
|
||
|
||
/**
|
||
** Parameter check. A valid filename is to be given.
|
||
**/
|
||
|
||
if( !filename) {
|
||
if( OK != ErrorLogger( ERR_PARAM, LOC, "filename", NULL))
|
||
return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
|
||
}
|
||
|
||
/**
|
||
** Check for the module 'magic cookie'
|
||
** Trust stdin as a valid module file ...
|
||
**/
|
||
|
||
if( !strcmp( filename, _fil_stdin) && !check_magic( filename,
|
||
MODULES_MAGIC_COOKIE, MODULES_MAGIC_COOKIE_LENGTH)) {
|
||
if( OK != ErrorLogger( ERR_MAGIC, LOC, filename, NULL))
|
||
return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
|
||
}
|
||
|
||
/**
|
||
** Now do execute that module file and evaluate the result of the
|
||
** latest executed command
|
||
**/
|
||
|
||
if( TCL_ERROR == (result = Execute_TclFile(interp, filename))) {
|
||
|
||
#if WITH_DEBUGGING_UTIL
|
||
ErrorLogger( NO_ERR_DEBUG, LOC, "Execution of '",
|
||
filename, "' failed", NULL);
|
||
#endif
|
||
|
||
if( *interp->result) {
|
||
char *tstr = NULL;
|
||
Tcl_RegExp retexpPtr;
|
||
|
||
tstr = strdup(interp->result);
|
||
retexpPtr = Tcl_RegExpCompile(interp, "^EXIT ([0-9]*)");
|
||
if( Tcl_RegExpExec(interp, retexpPtr, tstr, tstr)) {
|
||
Tcl_RegExpRange(retexpPtr, 1, &startp, &endp);
|
||
if( startp != '\0')
|
||
result = atoi( startp );
|
||
}
|
||
if (tstr)
|
||
null_free((void *) &tstr);
|
||
}
|
||
}
|
||
|
||
/**
|
||
** Return the result as derivered from the module file execution
|
||
**/
|
||
|
||
#if WITH_DEBUGGING_UTIL
|
||
ErrorLogger( NO_ERR_END, LOC, _proc_Read_Modulefile, NULL);
|
||
#endif
|
||
|
||
return( result);
|
||
|
||
} /** End of 'Read_Modulefile' **/
|
||
|
||
/*++++
|
||
** ** Function-Header ***************************************************** **
|
||
** **
|
||
** Function: Execute_TclFile **
|
||
** **
|
||
** Description: Read in and execute all commands concerning the Tcl **
|
||
** file passed as parameter **
|
||
** **
|
||
** First Edition: 91/10/23 **
|
||
** **
|
||
** Parameters: Tcl_Interp *interp According Tcl interp.**
|
||
** char *filename **
|
||
** **
|
||
** Result: int TCL_OK Successfull completion **
|
||
** TCL_ERROR Any error **
|
||
** **
|
||
** Attached Globals: line Input read buffer **
|
||
** **
|
||
** ************************************************************************ **
|
||
++++*/
|
||
|
||
int Execute_TclFile( Tcl_Interp *interp,
|
||
char *filename)
|
||
{
|
||
FILE *infile;
|
||
int gotPartial = 0;
|
||
int result = 0;
|
||
char *cmd;
|
||
Tcl_DString cmdbuf;
|
||
|
||
#if WITH_DEBUGGING_UTIL_1
|
||
ErrorLogger( NO_ERR_START, LOC, _proc_Execute_TclFile, NULL);
|
||
#endif
|
||
|
||
/**
|
||
** If there isn't a line buffer allocated so far, do it now
|
||
**/
|
||
|
||
if( line == NULL) {
|
||
if( NULL == (line = (char*) malloc( LINELENGTH * sizeof( char)))) {
|
||
if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
|
||
return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
|
||
}
|
||
}
|
||
|
||
/**
|
||
** If we're supposed to be interpreting from stdin, set infile
|
||
** equal to stdin, otherwise, open the file and interpret
|
||
**/
|
||
|
||
if( !strcmp( filename, _fil_stdin)) {
|
||
infile = stdin;
|
||
} else {
|
||
if( NULL == (infile = fopen( filename, "r"))) {
|
||
if( OK != ErrorLogger( ERR_OPEN, LOC, filename, "reading", NULL))
|
||
return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
|
||
}
|
||
}
|
||
|
||
/**
|
||
** Allow access to which file is being loaded.
|
||
**/
|
||
|
||
linenum = 0;
|
||
Tcl_SetVar( interp, "ModulesCurrentModulefile", filename, 0);
|
||
Tcl_DStringInit( &cmdbuf);
|
||
|
||
while( 1) {
|
||
|
||
linenum++;
|
||
if( fgets(line, LINELENGTH, infile) == NULL) {
|
||
if( !gotPartial) {
|
||
break; /** while **/
|
||
}
|
||
line[0] = '\0';
|
||
}
|
||
|
||
/**
|
||
** Put the whole command on the command buffer
|
||
**/
|
||
|
||
cmd = Tcl_DStringAppend( &cmdbuf, line, (-1));
|
||
|
||
if( line[0] != 0 && !Tcl_CommandComplete(cmd)) {
|
||
gotPartial++;
|
||
continue;
|
||
}
|
||
|
||
/**
|
||
** Now evaluate the command and react on its result
|
||
** Reinitialize the command buffer
|
||
**/
|
||
|
||
#if WITH_DEBUGGING_UTIL_1
|
||
ErrorLogger( NO_ERR_DEBUG, LOC, " Evaluating '", cmd, "'", NULL);
|
||
#endif
|
||
|
||
result = Tcl_Eval( interp, cmd);
|
||
|
||
if( TCL_ERROR == result) {
|
||
ErrorLogger( ERR_EXEC, LOC, cmd, NULL);
|
||
}
|
||
|
||
Tcl_DStringTrunc( &cmdbuf, 0);
|
||
|
||
#if WITH_DEBUGGING_UTIL_1
|
||
{
|
||
char buffer[ 80];
|
||
|
||
switch( result) {
|
||
case TCL_OK: strcpy( buffer, "TCL_OK");
|
||
break;
|
||
|
||
case TCL_ERROR: strcpy( buffer, "TCL_ERROR");
|
||
break;
|
||
|
||
case TCL_LEVEL0_RETURN:
|
||
strcpy( buffer, "TCL_LEVEL0_RETURN");
|
||
break;
|
||
}
|
||
|
||
ErrorLogger( NO_ERR_DEBUG, LOC, " Result: '", buffer, "'", NULL);
|
||
}
|
||
#endif
|
||
|
||
switch( result) {
|
||
|
||
case TCL_OK: gotPartial = 0;
|
||
continue; /** while **/
|
||
|
||
case TCL_ERROR: interp->errorLine = ((linenum-1)-gotPartial) +
|
||
interp->errorLine;
|
||
/* FALLTHROUGH */
|
||
|
||
case TCL_LEVEL0_RETURN:
|
||
break; /** switch **/
|
||
}
|
||
|
||
/**
|
||
** If the while loop hasn't been continued so far, it is to be broken
|
||
** now
|
||
**/
|
||
|
||
break; /** while **/
|
||
|
||
} /** while **/
|
||
|
||
/**
|
||
** Free up what has been used, close the input file and return the result
|
||
** of the last command to the caller
|
||
**/
|
||
|
||
Tcl_DStringFree( &cmdbuf);
|
||
if( EOF == fclose( infile))
|
||
if( OK != ErrorLogger( ERR_CLOSE, LOC, filename, NULL))
|
||
return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
|
||
|
||
#if WITH_DEBUGGING_UTIL_1
|
||
ErrorLogger( NO_ERR_END, LOC, _proc_Execute_TclFile, NULL);
|
||
#endif
|
||
|
||
return( result);
|
||
|
||
} /** End of 'Execute_TclFile' **/
|
||
|
||
/*++++
|
||
** ** Function-Header ***************************************************** **
|
||
** **
|
||
** Function: CallModuleProcedure **
|
||
** **
|
||
** Description: Call a Tcl Procedure **
|
||
** Executes the passed modulefile (conditionally hidden)**
|
||
** and then evaluates the passed Tcl procedure **
|
||
** **
|
||
** First Edition: 91/10/23 **
|
||
** **
|
||
** Parameters: Tcl_Interp *interp According Tcl interp.**
|
||
** Tcl_DString *cmdptr Buffer fot the Tcl **
|
||
** command **
|
||
** char *modulefile According module file**
|
||
** char *procname Name of the Tcl Proc.**
|
||
** int suppress_output Controlls redirect.**
|
||
** of stdout and stderr **
|
||
** **
|
||
** Result: int TCL_OK Successfull completion **
|
||
** TCL_ERROR Any error **
|
||
** **
|
||
** Attached Globals: - **
|
||
** **
|
||
** ************************************************************************ **
|
||
++++*/
|
||
|
||
int CallModuleProcedure( Tcl_Interp *interp,
|
||
Tcl_DString *cmdptr,
|
||
char *modulefile,
|
||
char *procname,
|
||
int suppress_output)
|
||
{
|
||
char cmdline[ LINELENGTH];
|
||
char *cmd;
|
||
int result;
|
||
int saved_stdout = 0, saved_stderr = 0, devnull;
|
||
|
||
#if WITH_DEBUGGING_UTIL_1
|
||
ErrorLogger( NO_ERR_START, LOC, _proc_CallModuleProcedure, NULL);
|
||
#endif
|
||
|
||
/**
|
||
** Must send stdout and stderr to /dev/null until the
|
||
** ModulesHelp procedure is called.
|
||
**/
|
||
|
||
if( suppress_output) {
|
||
if( 0 > (devnull = open( _fil_devnull, O_RDWR))) {
|
||
if( OK != ErrorLogger( ERR_OPEN, LOC, _fil_devnull, "changing", NULL))
|
||
return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
|
||
}
|
||
|
||
/**
|
||
** Close STDOUT and reopen it as /dev/null
|
||
**/
|
||
|
||
if( -1 == ( saved_stdout = dup( 1)))
|
||
if( OK != ErrorLogger( ERR_DUP, LOC, _fil_stdout, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
|
||
if( -1 == close( 1))
|
||
if( OK != ErrorLogger( ERR_CLOSE, LOC, _fil_stdout, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
|
||
if( -1 == dup( devnull))
|
||
if( OK != ErrorLogger( ERR_DUP, LOC, _fil_devnull, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
|
||
/**
|
||
** Close STDERR and reopen it as /dev/null
|
||
**/
|
||
|
||
if( -1 == ( saved_stdout = dup( 2)))
|
||
if( OK != ErrorLogger( ERR_DUP, LOC, _fil_stderr, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
|
||
if( -1 == close( 2))
|
||
if( OK != ErrorLogger( ERR_CLOSE, LOC, _fil_stderr, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
|
||
if( -1 == dup( devnull))
|
||
if( OK != ErrorLogger( ERR_DUP, LOC, _fil_devnull, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
}
|
||
|
||
/**
|
||
** Read the passed module file
|
||
**/
|
||
|
||
Read_Modulefile( interp, modulefile);
|
||
|
||
/**
|
||
** Reinstall stdout and stderr
|
||
**/
|
||
|
||
if( suppress_output) {
|
||
|
||
/**
|
||
** Reinstall STDOUT
|
||
**/
|
||
|
||
if( EOF == fflush( stdout))
|
||
if( OK != ErrorLogger( ERR_FLUSH, LOC, _fil_stdout, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
|
||
if( EOF == fflush( stderr))
|
||
if( OK != ErrorLogger( ERR_FLUSH, LOC, _fil_stderr, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
|
||
if( -1 == close( 1))
|
||
if( OK != ErrorLogger( ERR_CLOSE, LOC, _fil_stdout, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
|
||
/**
|
||
** Reinstall STDERR
|
||
**/
|
||
|
||
if( -1 == dup( saved_stdout))
|
||
if( OK != ErrorLogger( ERR_DUP, LOC, _fil_stdout, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
|
||
if( -1 == close( 2))
|
||
if( OK != ErrorLogger( ERR_CLOSE, LOC, _fil_stderr, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
|
||
if( -1 == dup( saved_stderr))
|
||
if( OK != ErrorLogger( ERR_DUP, LOC, _fil_stderr, NULL))
|
||
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
|
||
}
|
||
|
||
/**
|
||
** Now evaluate the Tcl Procedure
|
||
**/
|
||
|
||
/* sprintf( cmdline, "%s\n", procname); */
|
||
strcpy( cmdline, procname);
|
||
strcat( cmdline, "\n");
|
||
cmd = Tcl_DStringAppend( cmdptr, cmdline, (-1));
|
||
|
||
result = Tcl_Eval( interp, cmd);
|
||
Tcl_DStringTrunc( cmdptr, 0);
|
||
|
||
#if WITH_DEBUGGING_UTIL_1
|
||
ErrorLogger( NO_ERR_END, LOC, _proc_CallModuleProcedure, NULL);
|
||
#endif
|
||
|
||
return( result);
|
||
|
||
} /** End of 'CallModuleProcedure' **/
|