symbol
Block::name (const symbol key) const
{
const Frame& frame = find_frame (key);
if (frame.is_reference (key))
return name (expand_reference (key));
//Handle primitive names.
Attribute::type type = lookup (key);
if (type != Attribute::Model)
return expand_string (frame.name (key));
// Handle stringer objects.
daisy_assert (type == Attribute::Model);
daisy_assert (frame.component (key) == Stringer::component);
daisy_assert (frame.check (*this));
std::unique_ptr<Stringer> stringer (Librarian::build_frame<Stringer>
(*this, frame.model (key), key));
daisy_assert (stringer.get ());
daisy_assert (stringer->initialize (units (), *this, msg ()));
daisy_assert (stringer->check (units (), *this, msg ()));
stringer->tick (units (), *this, msg ());
daisy_assert (!stringer->missing (*this));
return symbol (stringer->value (*this));
}
static void
obj_coff_ident (int ignore ATTRIBUTE_UNUSED)
{
segT current_seg = now_seg;
subsegT current_subseg = now_subseg;
#ifdef TE_PE
{
segT sec;
/* We could put it in .comment, but that creates an extra section
that shouldn't be loaded into memory, which requires linker
changes... For now, until proven otherwise, use .rdata. */
sec = subseg_new (".rdata$zzz", 0);
bfd_set_section_flags (stdoutput, sec,
((SEC_ALLOC | SEC_LOAD | SEC_READONLY | SEC_DATA)
& bfd_applicable_section_flags (stdoutput)));
}
#else
subseg_new (".comment", 0);
#endif
stringer (1);
subseg_set (current_seg, current_subseg);
}
/******************************************************************************
Function: void printf_s1(char *msg,char *parm1)
By: David Schwartz
Date: Jan 1995
Parameters: msg - message text
p1 - parameter 1 (string)
Returns: None
Description: print out the string has 1 parameter to stick into the string
******************************************************************************/
void printf_s1(char *msg,char *parm1)
{
/* convert info */
sprintf(fnt_buffer,msg,parm1);
stringer();
return;
}
/******************************************************************************
Function: void mk_printf(char *cptr)
By: David Schwartz
Date: Jan 1995
Parameters: cptr - text to print
Returns: None
Description: print out the string
******************************************************************************/
void mk_printf(char *cptr)
{
memcpy(fnt_buffer,cptr,strlen(cptr)+1);
((char *)current_proc->pa8)=fnt_buffer;
stringer();
return;
}
int Module_Tcl_ExitCmd( ClientData client_data,
Tcl_Interp *interp,
int argc,
CONST84 char *argv[])
{
char *buffer; /** Buffer for sprintf **/
int value; /** Return value from exit command **/
#if WITH_DEBUGGING_CALLBACK
ErrorLogger( NO_ERR_START, LOC, _proc_Module_Tcl_ExitCmd, NULL);
#endif
/**
** Check the number of arguments. The exit command may take no or one
** parameter. So the following is legal:
** exit;
** exit value;
**/
if((argc != 1) && (argc != 2))
if( OK != ErrorLogger( ERR_USAGE, LOC, argv[0], "?returnCode?", NULL))
goto unwind0;
/**
** If the exit command comes with an paramter, set up the TCL result.
** Otherwise the result is 0.
**/
if( argc == 1) {
value = 0;
} else if( Tcl_GetInt( interp, argv[1], &value) != TCL_OK) {
if( OK != ErrorLogger( ERR_PARAM, LOC, argv[1], NULL))
goto unwind0;
}
/**
** Allocate memory
**/
if((char *) NULL == (buffer = stringer(NULL,25,NULL)))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
goto unwind0;
sprintf( buffer, "EXIT %d", value);
Tcl_SetResult( interp, buffer, NULL);
/**
** Exit from this module command.
** ??? Why hardcoded on error ???
**/
#if WITH_DEBUGGING_CALLBACK
ErrorLogger( NO_ERR_END, LOC, _proc_Module_Tcl_ExitCmd, NULL);
#endif
unwind0:
return( TCL_ERROR);
} /** End of 'Module_Tcl_ExitCmd' **/
String Anon_obj::toString()
{
Dynamic func;
if (FieldMapGet(mFields, HX_CSTRING("toString"), func))
return func();
String result = HX_CSTRING("{ ");
Stringer stringer(result);
mFields->Iterate(stringer);
return result + HX_CSTRING(" }");
}
/******************************************************************************
Function: void lm_printf_p1(FNTSETUP *fnt_info,WORD parm1)
By: David Schwartz
Date: Jan 1995
Parameters: fnt_info - data to init fnt_state, print string follows
p1 - parameter 1
Returns: None
Description: setup the fnt state and print out the string has 1 parameter to stick into the string
******************************************************************************/
void lm_printf_p1(FNTSETUP *fnt_info,WORD parm1)
{
lm_setup(fnt_info);
fnt_info++; // move to string
/* convert info */
sprintf(fnt_buffer,(char *)fnt_info,parm1);
stringer();
return;
}
void p7_left_p1(char *pa8,short pa9x,short pa9y,WORD parm1)
{
lm_setup(pf_7point_left);
fnt_state.fnt_posx=pa9x;
fnt_state.fnt_posy=pa9y;
/* convert info */
sprintf(fnt_buffer,pa8,parm1);
stringer();
return;
}
void pds_centered_p1(char *pa8,short pa9x,short pa9y,WORD parm1)
{
lm_setup(pf_dave_smallc);
fnt_state.fnt_posx=pa9x;
fnt_state.fnt_posy=pa9y;
/* convert info */
sprintf(fnt_buffer,pa8,parm1);
stringer();
return;
}
/* since when does 'main()' take three arguments? */
int main(int argc, char *argv[], char *environ[]) {
Tcl_Interp *interp;
int return_val = 0;
char *rc_name;
char *rc_path;
#if WITH_DEBUGGING
ErrorLogger(NO_ERR_START, LOC, _proc_main, NULL);
#endif /* WITH_DEBUGGING */
/**
** check if first argument is --version or -V then output the
** version to stdout. This is a special circumstance handled
** by the regular options.
**/
if ((argc > 1) && (*argv[1] == '-')) {
if ((!strcmp("-V", argv[1])) || (!strcmp("--version", argv[1]))) {
version(stdout);
return 0;
}
}
/**
** Initialization.
** Check the command line syntax. There will be no return from the
** initialization function in case of invalid command line arguments.
**/
if (TCL_OK != Initialize_Tcl(&interp, argc, argv, environ)) {
goto unwind0;
}
if (TCL_OK != Setup_Environment(interp)) {
goto unwind0;
}
/**
** Check for command line switches
**/
if (TCL_OK != Check_Switches(&argc, argv)) {
goto unwind0;
}
/**
** Figure out, which global RC file to use. This depends on the environ-
** ment variable 'MODULERCFILE', which can be set to one of the following:
**
** <filename> --> PREFIX/etc/<filename>
** <dir>/ --> <dir>/RC_FILE
** <dir>/<file> --> <dir>/<file>
** Use xgetenv to expand 1 level of env.vars.
**/
if ((rc_name = xgetenv("MODULERCFILE"))) {
/* found something in MODULERCFILE */
if ((char *)NULL == (rc_path = stringer(NULL, 0, rc_name, NULL))) {
if (OK != ErrorLogger(ERR_STRING, LOC, NULL)) {
goto unwind1;
} else {
null_free((void *)&rc_name);
}
} else {
null_free((void *)&rc_name);
if ((char *)NULL == (rc_name = strrchr(rc_path, '/'))) {
rc_name = rc_path;
rc_path = instpath;
} else {
*rc_name++ = '\0';
}
if (!*rc_name) {
rc_name = rc_file;
}
}
} else {
rc_path = instpath;
null_free((void *)&rc_name);
rc_name = rc_file;
}
/**
** Finally we have to change PREFIX -> PREFIX/etc
**/
if (rc_path == instpath) {
if ((char *)NULL == (rc_path = stringer(NULL, 0, instpath,
"/etc", NULL))) {
if (OK != ErrorLogger(ERR_ALLOC, LOC, NULL)) {
goto unwind1;
} else {
rc_path = NULL;
}
}
}
/**
** Source the global and the user defined RC file
**/
g_current_module = (char *)NULL;
if ((TCL_ERROR == SourceRC(interp, rc_path, rc_name)) ||
(TCL_ERROR == SourceRC(interp, getenv("HOME"), modulerc_file))) {
exit(1);
}
if (rc_path) {
null_free((void *)&rc_path);
}
/**
** Invocation of the module command as specified in the command line
**/
g_flags = 0;
return_val = cmdModule((ClientData)0, interp, (argc - 1),
(CONST84 char **)(argv + 1));
/**
** If we were doing some operation that has already flushed its output,
** then we do NOT need to re-flush the output here.
**
** Also, if we have had an error here, then the whole modulecmd failed
** and not just the values for a single modulefile. So, we shall pass in
** a NULL here to indicate that any error message should say that
** absolutely NO changes were made to the environment.
**/
if (TCL_OK == return_val) {
Output_Modulefile_Changes(interp);
#ifdef HAS_X11LIBS
xresourceFinish(1);
#endif /* HAS_X11LIBS */
} else {
Unwind_Modulefile_Changes(interp, NULL);
#ifdef HAS_X11LIBS
xresourceFinish(0);
#endif /* HAS_X11LIBS */
}
/**
** Finally clean up. Delete the required hash tables and conditionally
** allocated areas.
**/
Delete_Global_Hash_Tables();
if (line) {
null_free((void *)&line);
}
if (error_line) {
null_free((void *)&error_line);
}
/**
** This return value may be evaluated by the calling shell:
**/
#if WITH_DEBUGGING
ErrorLogger(NO_ERR_END, LOC, _proc_main, NULL);
#endif /* WITH_DEBUGGING */
OutputExit();
return (return_val ? return_val : g_retval);
unwind2:
null_free((void *)&rc_path);
unwind1:
null_free((void *)&rc_name);
unwind0:
/* an error occurred of some type */
g_retval = (g_retval ? g_retval : 1);
OutputExit();
return (g_retval);
} /** End of 'main' **/
static char *apropos_cache()
{
char *buffer, *env, *env_file, *env_path;
#if WITH_DEBUGGING_UTIL_1
/*
ErrorLogger( NO_ERR_START, LOC, _proc_apropos_cache, "dir='", dir, NULL);
*/
#endif
/**
** Figure out, what out global RC file is. This depends on the environ-
** ment variable 'MODULEWHATISCACHE', which can be set to one of the
** following:
**
** <filename> --> PREFIX/etc/<filename>
** <dir>/ --> <dir>/RC_FILE
** <dir>/<file> --> <dir>/<file>
**/
if( env = getenv( "MODULEWHATISCACHE")) {
if((char *) NULL == (env_file = strrchr( env, '/'))) {
env_file = env;
env_path = instpath;
} else {
*env_file++ = '\0';
env_path = env;
}
if( !*env_file)
env_file = cache_name;
} else {
env_path = instpath;
env_file = cache_name;
}
/**
** Finaly we have to change PREFIX -> PREFIX/etc
**/
if( env_path == instpath) {
if((char *) NULL == (buffer = stringer(NULL,0,
env_path,"/etc/",env_file,NULL)))
goto unwind0;
} else {
if((char *) NULL == (buffer = stringer(NULL,0,
env_path,"/",env_file,NULL)))
goto unwind0;
}
/**
** Return the name of the cache file
**/
#if WITH_DEBUGGING_UTIL_1
ErrorLogger( NO_ERR_END, LOC, _proc_apropos_cache, NULL);
#endif
return( buffer);
unwind0:
return (char *) NULL;
} /** End of 'apropos_cache' **/
static int whatis_dir( char *dir, int argc, char **argv, FILE *cfp,
int whatis_list)
{
fi_ent *dirlst_head = NULL; /** Directory list base pointer **/
int count = 0; /** Number of elements in the top **/
/** level directory list **/
int tcount = 0; /** Total number of files to print **/
char **list; /** flat list of module files **/
int start = 0, i, k;
int result = TCL_OK;
Tcl_Interp *whatis_interp;
Tcl_DString cmdbuf;
char modulefile[ MOD_BUFSIZE];
char **wptr, *c;
struct stat stats;
#if WITH_DEBUGGING_UTIL_1
ErrorLogger( NO_ERR_START, LOC, _proc_whatis_dir, "dir='", dir, NULL);
#endif
/**
** Normal reading of the files
**/
if( NULL == (dirlst_head = get_dir( dir, NULL, &count, &tcount)))
if( OK != ErrorLogger( ERR_READDIR, LOC, dir, NULL))
goto unwind0;
if( NULL == (list = (char**) module_malloc( tcount * sizeof( char**))))
if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
goto unwind1;
dirlst_to_list( list, dirlst_head, count, &start, NULL, NULL);
/**
** Initialize the command buffer and set up the modules flag to 'whatislay
** only'
**/
Tcl_DStringInit( &cmdbuf);
g_flags |= M_WHATIS;
/**
** Check all the files in the flat list for the passed tokens
**/
for( i=0; i<tcount; i++) {
whatis_interp = EM_CreateInterp();
if( TCL_OK != (result = InitializeModuleCommands( whatis_interp))) {
EM_DeleteInterp( whatis_interp);
result = TCL_ERROR;
break; /** for( i) **/
}
/**
** locate the filename related to the passed module
**/
if( (char *) NULL == stringer(modulefile,MOD_BUFSIZE,
dir,"/",list[i],NULL)) {
result = TCL_ERROR;
break; /** for( i) **/
}
g_current_module = list[ i];
if( stat( modulefile, &stats) || S_ISDIR( stats.st_mode))
continue;
cmdModuleWhatisInit();
result = CallModuleProcedure( whatis_interp, &cmdbuf, modulefile,
"ModulesApropos", 0);
/**
** Check if at least one of the passed tokens is found in the
** retrieved whatis strings. If yes, print the string.
**/
if( whatis) {
wptr = whatis;
while( *wptr) {
/**
** Cache output enabled?
**/
if( cfp)
fprintf( cfp, "%-21s: %s\n", list[i], *wptr);
/**
** Ignore case?
**/
if( sw_icase) {
strncpy( modulefile, *wptr, MOD_BUFSIZE);
for( c = modulefile; c && *c; c++)
*c = tolower( *c);
c = modulefile;
} else
c = *wptr;
/**
** Seek for the passed tokens
**/
if( whatis_list)
fprintf( stderr, "%-21s: %s\n", list[i], *wptr);
else
for( k=0; k<argc; k++) {
if( strstr( c, argv[ k]))
fprintf( stderr, "%-21s: %s\n", list[i], *wptr);
}
wptr++;
}
}
/**
** Remove the Tcl interpreter that has been used for printing ...
**/
EM_DeleteInterp( whatis_interp);
cmdModuleWhatisShut();
} /** for( i) **/
/**
** Cleanup
**/
g_flags &= ~M_WHATIS;
delete_dirlst( dirlst_head, count);
delete_cache_list( list, start);
#if WITH_DEBUGGING_UTIL_1
ErrorLogger( NO_ERR_END, LOC, _proc_whatis_dir, NULL);
#endif
return( result); /** ------- EXIT (result) --------> **/
unwind2:
delete_cache_list( list, start);
unwind1:
delete_dirlst( dirlst_head, count);
unwind0:
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
} /** End of 'whatis_dir' **/
int ModuleCmd_Switch( Tcl_Interp *interp,
int argc,
char *argv[])
{
char *oldmodule,
*newmodule,
*realname,
*oldfile,
*newfile,
*oldname,
*newname,
*oldmodule_buffer = (char *) NULL;
int ret_val = TCL_OK;
/**
** allocate buffer memory
**/
if (!(oldfile = stringer(NULL, MOD_BUFSIZE, NULL)))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
goto unwind0;
if (!(newfile = stringer(NULL, MOD_BUFSIZE, NULL)))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
goto unwind1;
if (!(oldname = stringer(NULL, MOD_BUFSIZE, NULL)))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
goto unwind2;
if (!(newname = stringer(NULL, MOD_BUFSIZE, NULL)))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
goto unwind3;
/**
** Parameter check. the required syntax is:
** module switch [ <old> ] <new>
** If <old> is not specified, then the pathname of <new> is assumed.
**/
if( argc == 1) {
newmodule = argv[0];
if(!(oldmodule_buffer = stringer(NULL,0,newmodule,NULL)))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
goto unwind4;
/* starting from the end of the module name, find the first
* forward slash and replace with null
*/
if ((oldmodule = strrchr(oldmodule_buffer, *psep))) {
*oldmodule = 0;
}
oldmodule = oldmodule_buffer;
} else if( argc == 2) {
oldmodule = argv[0];
newmodule = argv[1];
} else {
if( OK != ErrorLogger( ERR_USAGE, LOC, "switch oldmodule newmodule",
NULL))
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
}
/**
** Set the name of the module specified on the command line
**/
g_specified_module = oldmodule;
/**
** First try to find a match for the modulefile out of the LOADEDMODULES.
**/
if( !IsLoaded( interp, oldmodule, &realname, oldfile))
if( OK != ErrorLogger( ERR_NOTLOADED, LOC, oldmodule, NULL))
goto unwind4;
/**
** If we have another name to try, try finding it on disk.
**/
if( realname)
ret_val = Locate_ModuleFile( interp, realname, oldname, oldfile);
/**
** If we've made it this far without finding a file, then look using the
** exact name the user gave me -- i.e. the old method.
**/
if( ret_val == TCL_ERROR) {
if( TCL_ERROR == (ret_val = Locate_ModuleFile( interp, oldmodule,
oldname, oldfile)))
if( OK != ErrorLogger( ERR_LOCATE, LOC, oldmodule, NULL))
goto unwind4;
/**
** OK, this one is known. Is it loaded, too?
**/
if( !IsLoaded( interp, oldname, NULL, oldfile))
if( OK != ErrorLogger( ERR_NOTLOADED, LOC, oldmodule, NULL))
goto unwind4;
}
/**
** Set the name of the module specified on the command line
**/
g_specified_module = newmodule;
/**
** Now try to find the new file to swap with.
**/
if( TCL_ERROR == (ret_val = Locate_ModuleFile( interp, newmodule, newname,
newfile)))
if( OK != ErrorLogger( ERR_LOCATE, LOC, newmodule, NULL))
goto unwind4;
ErrorLogger( NO_ERR_VERBOSE, LOC, "Switching '$1' to '$2'", oldmodule,
newmodule, NULL);
/**
** We'll remove the current modulefile with the SWITCH1 state set.
** This means that instead of really removing the paths, markers will
** be put in its place for later use.
**/
g_flags |= (M_REMOVE | M_SWSTATE1);
g_specified_module = oldmodule;
g_current_module = oldname;
if( Read_Modulefile( interp, oldfile) == 0)
Update_LoadedList( interp, oldname, oldfile);
else {
ErrorLogger( NO_ERR_VERBOSE, LOC, "failed", NULL);
goto unwind4;
}
g_flags &= ~(M_REMOVE | M_SWSTATE1);
/**
** Move on to state SWITCH2. This loads the modulefile at the append
** and prepend markers.
**/
g_flags |= M_SWSTATE2;
g_specified_module = newmodule;
g_current_module = newname;
if( Read_Modulefile( interp, newfile) == 0)
Update_LoadedList( interp, newname, newfile);
else {
ErrorLogger( NO_ERR_VERBOSE, LOC, "failed", NULL);
goto unwind4;
}
g_flags &= ~M_SWSTATE2;
/**
** This actually unsets environment variables and gets rid of the
** markers.
**/
g_flags |= (M_REMOVE | M_SWSTATE3);
g_specified_module = oldmodule;
g_current_module = oldname;
if( Read_Modulefile( interp, oldfile) == 0)
Update_LoadedList( interp, newname, newfile);
else {
ErrorLogger( NO_ERR_VERBOSE, LOC, "failed", NULL);
goto unwind4;
}
/**
** Return on success
**/
ErrorLogger( NO_ERR_VERBOSE, LOC, "done", NULL);
/**
** free space
** assume don't need what's pointed to by g_current_module
** and g_specified_module
**/
null_free((void *) &newname);
null_free((void *) &oldname);
null_free((void *) &newfile);
null_free((void *) &oldfile);
return( TCL_OK); /** ------- EXIT (SUCCESS) --------> **/
unwind4:
if (oldmodule == oldmodule_buffer)
null_free((void *) &oldmodule);
null_free((void *) &newname);
unwind3:
null_free((void *) &oldname);
unwind2:
null_free((void *) &newfile);
unwind1:
null_free((void *) &oldfile);
unwind0:
return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
} /** End of 'ModuleCmd_Switch' **/
static char *GetModuleName(Tcl_Interp *interp, char *path, char *prefix,
char *modulename)
{
struct stat stats; /** Buffer for the stat() systemcall **/
char *fullpath = NULL; /** Buffer for creating path names **/
char *Result = NULL; /** Our return value **/
char **filelist = NULL; /** Buffer for a list of possible
** module files **/
int numlist; /** Size of this list **/
int i, slen, is_def;
char *s, *t; /** Private string buffer **/
char *mod, *ver; /** Pointer to module and version **/
char *mod1, *ver1; /** Temp pointer **/
#if WITH_DEBUGGING_LOCATE_1
ErrorLogger(NO_ERR_START, LOC, _proc_GetModuleName, NULL);
#endif /* WITH_DEBUGGING_LOCATE_1 */
/**
** Split the modulename into module and version. Use a private buffer
** for this
**/
if ((char *)NULL == (s = stringer(NULL, 0, modulename, NULL))) {
ErrorLogger(ERR_ALLOC, LOC, NULL);
goto unwind0;
}
slen = (int)(strlen(s) + 1);
mod = s;
/* assume that the '=' here is correct, because otherwise 'ver' would not
* be initialized here yet (I think): */
if ((ver = strrchr(mod, '/'))) {
*ver++ = '\0';
}
/**
** Allocate a buffer for full pathname building:
**/
if ((char *)NULL == (fullpath = stringer(NULL, MOD_BUFSIZE, NULL))) {
if (OK != ErrorLogger(ERR_STRING, LOC, NULL)) {
goto unwind1;
}
}
/**
** Check whether $path/$prefix/$modulename is a directory.
**/
if (prefix) {
if ((char *)NULL == stringer(fullpath, MOD_BUFSIZE, path, "/", prefix,
"/", modulename, NULL)) {
goto unwind1;
}
} else {
if ((char *)NULL == stringer(fullpath, MOD_BUFSIZE, path, "/",
modulename, NULL)) {
goto unwind1;
}
}
if (!stat(fullpath, &stats) && S_ISDIR(stats.st_mode)) {
/**
** So the full modulename is $modulename/default. Recurse on that.
**/
if ((char *)NULL == (t = stringer(NULL, 0, modulename, "/",
_default, NULL))) {
goto unwind1;
}
Result = GetModuleName(interp, path, prefix, t);
null_free((void *)&t);
null_free((void *)&fullpath);
null_free((void *)&s);
return (Result);
}
/**
** Check whether $path/$prefix/$mod is a directory:
**/
if (prefix) {
if ((char *)NULL == stringer(fullpath, MOD_BUFSIZE, path, "/", prefix,
"/", mod, NULL)) {
goto unwind1;
}
} else {
if ((char *)NULL == stringer(fullpath, MOD_BUFSIZE, path, "/",
mod, NULL)) {
goto unwind1;
}
}
is_def = !strcmp(mod, _default);
if (is_def || !stat(fullpath, &stats)) {
/**
** If it is a directory, then do this:
**/
if (!is_def && S_ISDIR( stats.st_mode)) {
/**
** Source the ".modulerc" file if it exists.
** For compatibility source the .version file, too.
**/
if (prefix) {
if ((char *)NULL == stringer(modfil_buf, MOD_BUFSIZE,
prefix, "/", mod, NULL)) {
goto unwind2;
}
} else {
if ((char *)NULL == stringer(modfil_buf, MOD_BUFSIZE,
mod, NULL)) {
goto unwind2;
}
}
if ((char *)NULL == stringer(fullpath, MOD_BUFSIZE, path, "/",
modfil_buf, NULL)) {
goto unwind2;
}
g_current_module = modfil_buf;
if ((TCL_ERROR == SourceRC(interp, fullpath, modulerc_file)) ||
(TCL_ERROR == SourceVers(interp, fullpath, modfil_buf))) {
/* flags = save_flags; */
goto unwind2;
}
/**
** After sourcing the RC files, we have to look up the
** versions again:
**/
if (VersionLookup(modulename, &mod1, &ver1)) {
int len = (int)(strlen(mod1) + strlen(ver1) + 2);
/**
** Maybe we have to enlarge s:
**/
if (len > slen) {
null_free((void *)&s);
if((char *)NULL == (s = stringer( NULL, len, NULL))) {
ErrorLogger( ERR_STRING, LOC, NULL);
goto unwind2;
}
slen = len;
/* dummy condition to use 'slen': */
if (slen == 0) {
;
}
}
/**
** Print the new module/version in the buffer:
**/
if ((char *)NULL == stringer(s, len, mod1, "/", ver1, NULL)) {
ErrorLogger(ERR_STRING, LOC, NULL);
goto unwind2;
}
mod = s;
if (ver = strchr(s, (int)'/')) {
*ver++ = '\0';
}
}
/**
** recursively delve into subdirectories (until ver == NULL).
**/
if (ver) {
int len;
len = (int)(strlen(mod) + 1);
if (prefix) {
len += (strlen(prefix) + 1);
}
/**
** Build the new prefix
**/
if((char *) NULL == (t = stringer(NULL, len, NULL))) {
ErrorLogger( ERR_STRING, LOC, NULL);
goto unwind2;
}
if( prefix) {
if((char *) NULL == stringer(t, len, prefix,"/",mod, NULL)){
ErrorLogger( ERR_STRING, LOC, NULL);
goto unwindt;
}
} else {
if((char *) NULL == stringer(t, len, mod, NULL)){
ErrorLogger( ERR_STRING, LOC, NULL);
goto unwindt;
}
}
/**
** This is the recursion
**/
Result = GetModuleName( interp, path, t, ver);
/**
** Free our temporary prefix buffer
**/
null_free((void *) &t);
if (0) { /* an error occurred */
unwindt:
null_free((void *) &t);
goto unwind2;
}
}
} else { /** if ($path/$prefix/$mod is a directory) **/
/**
** Now 'mod' should be either a file or the word 'default'
** In case of default get the file with the highest version number
** in the current directory
**/
if( is_def) {
if( !prefix)
prefix = ".";
if( NULL == (filelist = SortedDirList( interp, path, prefix,
&numlist)))
goto unwind1;
prefix = (char *)NULL;
/**
** Select the first one on the list which is either a
** modulefile or another directory. We start at the highest
** lexicographical name in the directory since the filelist
** is reverse sorted.
** If it is a directory, then we delve into it.
**/
for( i=0; i<numlist && Result==NULL; i++) {
/**
** Build the full path name and check if it is a
** directory. If it is, recursively try to find there what
** we are/were seeking for
**/
if ((char *)NULL == stringer(fullpath, MOD_BUFSIZE,
path, "/", filelist[i], NULL))
goto unwind2;
if( !stat( fullpath, &stats) && S_ISDIR( stats.st_mode)) {
Result = GetModuleName( interp, path, prefix,
filelist[ i]);
} else {
/**
** Otherwise check the file for a magic cookie ...
**/
if( check_magic( fullpath, MODULES_MAGIC_COOKIE,
MODULES_MAGIC_COOKIE_LENGTH))
Result = filelist[ i];
} /** end "if (!stat)" **/
} /** end for-loop **/
} else { /** default **/
/**
** If mod names a file, we have to check wheter it exists and
** is a valid module file
**/
if( check_magic( fullpath, MODULES_MAGIC_COOKIE,
MODULES_MAGIC_COOKIE_LENGTH))
Result = mod;
else {
ErrorLogger( ERR_MAGIC, LOC, fullpath, NULL);
Result = NULL;
}
} /** if( mod is a filename) **/
/**
** Build the full filename (using prefix and Result) if
** Result is defined
**/
if (Result) {
int len;
len = (int)(strlen(Result) + 1);
if (prefix) {
len += (strlen(prefix) + 1);
}
if((char *) NULL == (t = stringer(NULL, len, NULL))) {
ErrorLogger( ERR_STRING, LOC, NULL);
goto unwind2;
}
if( prefix) {
if((char *) NULL == stringer(t,len, prefix,"/",Result,NULL))
goto unwindt2;
} else {
if((char *) NULL == stringer(t,len, Result,NULL))
goto unwindt2;
}
Result = t;
if (0) { /* an error occurred */
unwindt2:
null_free((void *) &t);
goto unwind2;
}
}
} /** mod is a file **/
} /** mod exists **/
/**
** Free up temporary values and return what we've found
**/
null_free((void*) &fullpath);
null_free((void*) &s);
FreeList(filelist, numlist);
#if WITH_DEBUGGING_LOCATE_1
ErrorLogger(NO_ERR_END, LOC, _proc_GetModuleName, NULL);
#endif /* WITH_DEBUGGING_LOCATE_1 */
return (Result); /** -------- EXIT (SUCCESS) -------> **/
unwind2:
null_free((void *)&fullpath);
unwind1:
null_free((void *)&s);
unwind0:
return(NULL); /** -------- EXIT (FAILURE) -------> **/
} /** End of 'GetModuleName' (that was a lengthy function...) **/
int Locate_ModuleFile( Tcl_Interp *interp,
char *modulename,
char *realname,
char *filename)
{
char *p; /** Tokenization pointer **/
char *result = NULL; /** This functions result **/
char **pathlist; /** List of paths to scan **/
int numpaths, /** Size of this list **/
i; /** Loop counter **/
char *modulespath; /** Buffer for the contents of the **/
/** environment variable MODULEPATH **/
char *mod, *vers; /** Module and version name for sym- **/
/** bolic name lookup **/
/**
** If it is a full path name, that's the module file to load.
**/
#if WITH_DEBUGGING_LOCATE
ErrorLogger( NO_ERR_START, LOC, _proc_Locate_ModuleFile, "modulename = '",
modulename, "'", NULL);
#endif
if( !modulename)
if( OK != ErrorLogger( ERR_PARAM, LOC, "modulename", NULL))
goto unwind0;
if( modulename[0] == '/' || modulename[0] == '.') {
p = (char*) strrchr( modulename, '/');
if(p) {
*p = '\0';
/**
** Check, if what has been specified is a valid version of
** the specified module ...
**/
if((char *) NULL ==
(result = GetModuleName(interp, modulename, NULL,(p+1))))
goto unwind0;
/**
** Reinstall the 'modulefile' which has been corrupted by
** tokenization
**/
*p = '/';
/**
** Reinstall the 'modulefile' which has been corrupted by
** tokenization
**/
*p = '/';
/**
** ... Looks good! Conditionally (if there has been no version
** specified) we have to add the default version
**/
if( !strcmp((p + 1), result)) {
if ((char *) NULL == stringer( filename, MOD_BUFSIZE,
modulename, NULL))
goto unwind1;
} else {
if ((char *) NULL == stringer( filename, MOD_BUFSIZE,
modulename,"/",result, NULL))
goto unwind1;
}
} else {
/**
** Hmm! There's no backslash in 'modulename'. So it MUST begin
** on '.' and MUST be part of the current directory
**/
if( NULL == (result = GetModuleName( interp, modulename, NULL,
modulename)))
goto unwind0;
if( !strcmp( modulename, result) ||
(strlen( modulename) + 1 + strlen( result) + 1 > MOD_BUFSIZE)) {
if ((char *) NULL == stringer( filename, MOD_BUFSIZE,
modulename, NULL))
goto unwind1;
} else {
if ((char *) NULL == stringer( filename, MOD_BUFSIZE,
modulename,"/",result, NULL))
goto unwind1;
}
}
/**
** So it is not a full path name what has been specified. Scan the
** MODULESPATH
**/
} else {
/**
** If I don't find a path in MODULEPATH, there's nothing to search.
**/
if( !( modulespath = (char *) getenv( "MODULEPATH"))) {
if( OK != ErrorLogger( ERR_MODULE_PATH, LOC, NULL)) {
g_current_module = NULL;
goto unwind0;
}
}
/**
** strip off any extraneous new lines
**/
{ char *end;
if ((char *) NULL != (end = strrchr(modulespath, '\n'))) *end = '\0';
}
/**
** Expand the module name (in case it is a symbolic one). This must
** be done once here in order to expand any aliases
**/
if( VersionLookup( modulename, &mod, &vers)) {
if ((char *) NULL == stringer( buf, MOD_BUFSIZE,
mod,"/",vers, NULL))
goto unwind0;
modulename = buf;
}
/**
** Split up the MODULEPATH values into multiple directories
**/
if( NULL == (pathlist = SplitIntoList(interp, modulespath, &numpaths,
_colon)))
goto unwind0;
/**
** Check each directory to see if it contains the module
**/
for(i=0; i<numpaths; i++) {
/* skip empty paths */
if(*pathlist[i] && (NULL != (result =
GetModuleName( interp, pathlist[i], NULL, modulename)))) {
if( strlen( pathlist[i]) + 2 + strlen( result) > MOD_BUFSIZE) {
if ((char *) NULL == stringer( filename, MOD_BUFSIZE,
pathlist[i], NULL))
goto unwind1;
} else {
if ((char *) NULL == stringer( filename, MOD_BUFSIZE,
pathlist[i],"/",result, NULL))
goto unwind1;
}
break;
}
/**
** If we havn't found it, we should try to re-expand the module
** name, because some rc file have been sourced
**/
if( VersionLookup( modulename, &mod, &vers)) {
if ((char *) NULL == stringer( buf, MOD_BUFSIZE,
mod,"/",vers, NULL))
goto unwind1;
modulename = buf;
}
} /** for **/
/**
** Free the memory created from the call to SplitIntoList()
**/
FreeList( pathlist, numpaths);
/**
** If result still NULL, then we really never found it and we should
** return ERROR and clear the full_path array for cleanliness.
**/
if( !result) {
filename[0] = '\0';
goto unwind0;
}
} /** not a full path name **/
/**
** Free up what has been allocated and pass the result back to
** the caller and save the real module file name returned by
** GetModuleName
**/
strncpy( realname, result, MOD_BUFSIZE);
if ((char *) NULL == stringer( realname, MOD_BUFSIZE, result, NULL))
goto unwind1;
null_free((void *) &result);
#if WITH_DEBUGGING_LOCATE
ErrorLogger( NO_ERR_END, LOC, _proc_Locate_ModuleFile, NULL);
#endif
return( TCL_OK);
unwind1:
null_free((void *) &result);
unwind0:
return( TCL_ERROR);
}
int SourceRC(Tcl_Interp *interp, char *path, char *name)
{
struct stat stats; /** Buffer for the stat() systemcall **/
int save_flags, i = 0;
char *buffer;
int Result = TCL_OK;
static char **srclist = (char **)NULL;
static int listsize = 0, listndx = 0;
/* dummy condition to use 'i': */
if (i == 0) {
;
}
/**
** If there is a problem with the input parameters it means, that
** we do not have to source anything
** Only a valid TCL interpreter should be there
**/
if (!path || !name) {
return (TCL_OK);
}
if (!interp) {
return (TCL_ERROR);
}
/**
** Build the full name of the RC file
** Avoid duplicate sourcing
**/
if ((char *)NULL == (buffer = stringer(NULL, 0, path,"/", name, NULL))) {
if (OK != ErrorLogger(ERR_STRING, LOC, NULL)) {
goto unwind0;
}
}
/**
** Check whether the RC file exists and has the magic cookie inside
**/
if (!stat(buffer, &stats)) {
if (check_magic(buffer, MODULES_MAGIC_COOKIE,
MODULES_MAGIC_COOKIE_LENGTH)) {
/**
** Set the flags to 'load only'. This prevents from accidently
** printing something
**/
save_flags = g_flags;
g_flags = M_LOAD;
/**
** Source now
**/
if (TCL_ERROR == Execute_TclFile(interp, buffer)) {
if (OK != ErrorLogger(ERR_SOURCE, LOC, buffer, NULL)) {
Result = TCL_ERROR;
}
}
g_flags = save_flags;
/**
** Save the currently sourced file in the list
** Check whether the list is big enough to fit in a new entry
**/
if (!listsize) {
listsize = SRCFRAG;
if ((char **)NULL == (srclist = (char **)module_malloc((size_t)((unsigned long)listsize * sizeof(char **))))) {
ErrorLogger(ERR_ALLOC, LOC, NULL);
goto unwind1;
}
} else if ((listndx + 1) >= listsize) {
listsize += SRCFRAG;
if (!(srclist = (char **)module_realloc(srclist,
(size_t)((unsigned long)listsize * sizeof(char **))))) {
ErrorLogger(ERR_ALLOC, LOC, NULL);
goto unwind1;
}
}
/**
** Put the current RC files name on the list:
**/
srclist[listndx++] = buffer;
} else {
ErrorLogger(ERR_MAGIC, LOC, buffer, NULL);
null_free((void *)&buffer);
}
} /** end "if (!stat)" **/
/**
** Return our result
**/
return (Result);
unwind1:
null_free((void *)&buffer);
unwind0:
return (TCL_ERROR);
} /** End of 'SourceRC' **/
int Initialize_Tcl( Tcl_Interp **interp,
int argc,
char *argv[],
char *environ[])
{
int Result = TCL_ERROR;
char * tmp;
#if WITH_DEBUGGING_INIT
ErrorLogger( NO_ERR_START, LOC, _proc_Initialize_Tcl, NULL);
#endif
/**
** Check the command syntax. Since this is already done
** Less than 3 parameters isn't valid. Invocation should be
** 'modulecmd <shell> <command>'
**/
if(argc < 2)
if( OK != ErrorLogger( ERR_USAGE, LOC, argv[0], " shellname", NULL))
goto unwind0;
/**
** Check the first parameter to modulcmd for a known shell type
** and set the shell properties
**/
if( !set_shell_properties( argv[1]))
if( OK != ErrorLogger( ERR_SHELL, LOC, argv[1], NULL))
goto unwind0;
/**
** Create a Tcl interpreter in order to proceed the command. Initialize
** this interpreter and set up pointers to all Tcl Module commands
** (InitializeModuleCommands)
**/
#ifdef __CYGWIN__
/* ABr, 12/10/01: from Cygwin stuff */
Tcl_FindExecutable( argv[0] ) ;
#endif
*interp = EM_CreateInterp();
if( TCL_OK != (Result = InitializeModuleCommands( *interp)))
goto unwind0;
/**
** Now set up the hash-tables for shell environment modifications.
** For a description of these tables have a look at main.c, where
** they're defined. The tables have to be allocated and thereafter
** initialized. Exit from the whole program in case allocation fails.
**/
if( ( ! ( setenvHashTable =
(Tcl_HashTable*) module_malloc( sizeof(Tcl_HashTable))) ) ||
( ! ( unsetenvHashTable =
(Tcl_HashTable*) module_malloc( sizeof(Tcl_HashTable))) ) ||
( ! ( aliasSetHashTable =
(Tcl_HashTable*) module_malloc( sizeof(Tcl_HashTable))) ) ||
( ! ( aliasUnsetHashTable =
(Tcl_HashTable*) module_malloc( sizeof(Tcl_HashTable))) ) ||
( ! ( markVariableHashTable =
(Tcl_HashTable*) module_malloc( sizeof(Tcl_HashTable))) ) ||
( ! ( markAliasHashTable =
(Tcl_HashTable*) module_malloc( sizeof(Tcl_HashTable))) ) ) {
if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
goto unwind0;
}
Tcl_InitHashTable( setenvHashTable, TCL_STRING_KEYS);
Tcl_InitHashTable( unsetenvHashTable, TCL_STRING_KEYS);
Tcl_InitHashTable( aliasSetHashTable, TCL_STRING_KEYS);
Tcl_InitHashTable( aliasUnsetHashTable, TCL_STRING_KEYS);
Tcl_InitHashTable( markVariableHashTable, TCL_STRING_KEYS);
Tcl_InitHashTable( markAliasHashTable, TCL_STRING_KEYS);
#ifdef BEGINENV
# if BEGINENV == 99
/**
** Check for the existence of the environment variable
** "MODULESBEGINENV". This signals that for this
** configuration that the user wants to record the initial
** environment as seen for the first time by the module
** command into the filename given in the MODULESBEGINENV
** environment variable (which can have one level of
** variable expansion). Whether it's the first time or not
** is moderated by the existence of environment variable
** _MODULESBEGINENV_ or not.
**
** The update command will use this information to reinitialize the
** environment and then reload every modulefile that has been loaded
** since as stored in the LOADEDMODULES environment variable in order.
**/
if( (tmp = xgetenv( "MODULESBEGINENV")) ) {
/* MODULESBEGINENV is set ... use it */
if( !getenv( "_MODULESBEGINENV_") ) {
FILE* file;
if( (file = fopen(tmp, "w+")) ) {
int i=0;
while( environ[i]) {
fprintf( file, "%s\n", environ[i++]);
}
moduleSetenv( *interp, "_MODULESBEGINENV_", tmp, 1);
fclose( file);
} else
if( OK != ErrorLogger( ERR_OPEN, LOC,
TCL_RESULT(*interp), "append", NULL))
goto unwind0;
null_free((void *) &tmp);
}
}
# else
/**
** Check for the existence of the
** environment variable "_MODULESBEGINENV_". If it is set, then
** do nothing, otherwise, Store every environment variable into
** ~/.modulesbeginenv. This will be used to store the environment
** variables exactly as it was when Modules saw it for the very first
** time.
**
** The update command will use this information to reinitialize the
** environment and then reload every modulefile that has been loaded
** since as stored in the LOADEDMODULES environment variable in order.
**/
if( !getenv( "_MODULESBEGINENV_") ) {
/* use .modulesbeginenv */
FILE* file;
char savefile[] = "/.modulesbeginenv";
char *buffer;
tmp = getenv("HOME");
if((char *) NULL == (tmp = getenv("HOME")))
if( OK != ErrorLogger( ERR_HOME, LOC, NULL))
goto unwind0;
if((char *) NULL == (buffer = stringer(NULL,0,tmp,savefile,NULL)))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
goto unwind0;
if( file = fopen(buffer, "w+")) {
int i=0;
while( environ[i]) {
fprintf( file, "%s\n", environ[i++]);
}
moduleSetenv( *interp, "_MODULESBEGINENV_", buffer, 1);
fclose( file);
} else
if( OK != ErrorLogger( ERR_OPEN, LOC,
TCL_RESULT(*interp), "append", NULL))
goto unwind0;
null_free((void *) &buffer);
}
# endif
#endif
/**
** Exit to the main program
**/
return( TCL_OK); /** -------- EXIT (SUCCESS) -------> **/
unwind0:
return( Result); /** -------- EXIT (FAILURE) -------> **/
} /** End of 'Initialize_Tcl' **/
int cmdSetPath(ClientData client_data, Tcl_Interp *interp, int argc,
CONST84 char *argv[])
{
Tcl_RegExp chkexpPtr; /** Regular expression for
* marker checking **/
char *oldpath, /** Old value of 'var' **/
*newpath, /** New value of 'var' **/
*sw_marker = APP_SW_MARKER, /** arbitrary default **/
*startp = NULL, *endp = NULL, /** regexp match endpts **/
*qualifiedpath, /** List of dirs which
* are NOT already in path **/
**pathlist; /** List of dirs **/
const char *delim = _colon; /** path delimiter **/
int append = 1, /** append or prepend **/
numpaths, /** number of dirs in path **/
qpathlen, /** qualifiedpath length **/
arg1 = 1, /** arg start **/
x; /** loop index **/
Tcl_Obj *np_obj; /** new path Tcl Obj **/
#if WITH_DEBUGGING_CALLBACK
ErrorLogger(NO_ERR_START, LOC, _proc_cmdSetPath, NULL);
#endif /* WITH_DEBUGGING_CALLBACK */
/**
** Whatis mode?
**/
if (g_flags & (M_WHATIS | M_HELP)) {
goto success0;
}
/**
** Check arguments. There should be at least 3 args:
** argv[0] - prepend/append
** ...
** argv[n-1]- varname
** argv[n] - value
**/
if(argc < 3) {
if (OK != ErrorLogger(ERR_USAGE, LOC, argv[0],
" path-variable directory", NULL)) {
goto unwind0;
}
}
/**
** Should this guy be removed from the variable(?)... If yes, then do so!
**/
if (g_flags & M_REMOVE) {
return (cmdRemovePath(client_data, interp, argc, argv)); /** ----> **/
}
/**
** prepend or append. The default is append.
**/
if (!(append = !!strncmp(argv[0], "pre", 3))) {
sw_marker = PRE_SW_MARKER;
}
/**
** Non-persist mode?
**/
if (g_flags & M_NONPERSIST) {
return (TCL_OK);
}
/**
** Display only ... ok, let us do so!
**/
if (g_flags & M_DISPLAY) {
fprintf(stderr, "%s\t ", argv[0]);
while (--argc) {
fprintf( stderr, "%s ", *++argv);
}
fprintf(stderr, "\n");
goto success0;
}
/**
** Check for the delimiter option
**/
if (*(argv[arg1]) == '-') {
if (!strcmp(argv[arg1], "-d")) {
delim = argv[(arg1 + 1)];
arg1 += 2;
} else if (!strcmp(argv[arg1], "--delim")) {
delim = argv[(arg1 + 1)];
arg1 += 2;
} else if (!strncmp(argv[arg1], "--delim=", 8)) {
delim = (argv[arg1] + 8);
arg1++;
}
}
/**
** Get the old value of the variable. MANPATH defaults to a configure
** generated value.
** Put a \ in front of each '.' and '+'.
** (this is an intentional memory leak)
**/
oldpath = EMGetEnv(interp, argv[arg1]);
_TCLCHK(interp)
if(!oldpath || !*oldpath) {
null_free((void *) &oldpath);
oldpath = ((!strcmp(argv[arg1], "MANPATH"))
? stringer(NULL, 0, DEFAULTMANPATH, NULL)
: stringer(NULL, 0, "", NULL));
}
/**
** Split the new path into its components directories so each
** directory can be checked to see whether it is already in the
** existing path.
**/
if (!(pathlist = SplitIntoList(interp, (char *)argv[(arg1 + 1)],
&numpaths, delim))) {
goto unwind0;
}
/**
** Some space for the list of paths which
** are not already in the existing path.
**/
if((char *) NULL == (qualifiedpath = stringer(NULL, 0, argv[(arg1 + 1)],
delim, NULL))) {
if (OK != ErrorLogger(ERR_STRING, LOC, NULL)) {
goto unwind1;
}
}
qpathlen = (int)(strlen(qualifiedpath) + 1);
*qualifiedpath = '\0'; /** make sure null for later **/
for ((x = 0); (x < numpaths); x++) {
regex_quote(pathlist[x], buffer, PATH_BUFLEN);
/**
** Check to see if path is already in this path variable.
** It could be at the
** beginning ... ^path:
** middle ... :path:
** end ... :path$
** only one ... ^path$
**/
if ((char *)NULL == (newpath = stringer(NULL, 0, "(^", buffer, delim,
")|(", delim, buffer, delim,
")|(", delim, buffer, "$)|(^",
buffer, "$)", NULL))) {
if (OK != ErrorLogger( ERR_STRING, LOC, NULL)) {
goto unwind2;
}
}
np_obj = Tcl_NewStringObj(newpath, (int)strlen(newpath));
chkexpPtr = Tcl_GetRegExpFromObj(interp, np_obj, TCL_REG_ADVANCED);
_TCLCHK(interp)
null_free((void *)&newpath);
/**
** If the directory is not already in the path,
** add it to the qualified path.
**/
if (!Tcl_RegExpExec(interp, chkexpPtr, oldpath, oldpath)) {
if (!stringer((qualifiedpath + strlen(qualifiedpath)),
(int)((unsigned long)qpathlen - strlen(qualifiedpath)),
pathlist[x], delim, NULL)) {
if (OK != ErrorLogger(ERR_STRING, LOC, NULL)) {
goto unwind2;
}
}
}
} /** End of loop that checks for
** already existent path
**/
/**
** If all of the directories in the new path already exist,
** exit doing nothing.
**/
if (! *qualifiedpath) {
goto success1;
}
/* remove trailing delimiter */
qualifiedpath[(strlen(qualifiedpath) - 1)] = '\0';
/**
** Some space for our newly created path.
** We size at the oldpath plus the addition.
**/
if (!(newpath = stringer(NULL, (int)(strlen(oldpath) + strlen(qualifiedpath) + 2), NULL))) {
if (OK != ErrorLogger(ERR_STRING, LOC, NULL)) {
goto unwind2;
}
}
*newpath = '\0';
/**
** Easy job to do, if the old path has not been set up so far ...
**/
if (!strcmp(oldpath, "")) {
strcpy(newpath, qualifiedpath);
/**
** Otherwise we have to take care on prepending vs. appending ...
** If there is a append or prepend marker within the variable (see
** modules_def.h) the changes are made according to this markers. Other-
** wise append and prepend will be relative to the strings begin or end.
**/
} else {
Tcl_Obj *sw_obj = Tcl_NewStringObj(sw_marker, (int)strlen(sw_marker));
Tcl_RegExp markexpPtr = Tcl_GetRegExpFromObj(interp,
sw_obj,
TCL_REG_ADVANCED);
_TCLCHK(interp)
strcpy(newpath, oldpath);
if (Tcl_RegExpExec(interp, markexpPtr, oldpath, oldpath)) {
_TCLCHK(interp)
Tcl_RegExpRange(markexpPtr, 0,
(CONST84 char **)&startp, (CONST84 char **)&endp);
/**
** Append/Prepend marker found
**/
if (append) {
char ch = *startp;
*startp = '\0';
strcpy(newpath, oldpath);
/**
** check that newpath has a value before adding delim
**/
if ((strlen(newpath) > 0) &&
(newpath[(strlen(newpath) - 1)] != *delim)) {
strcat(newpath, delim);
}
strcat(newpath, qualifiedpath);
if (newpath[strlen(newpath)-1] != *delim) {
strcat(newpath, delim);
}
*startp = ch;
strcat(newpath, startp);
} else {
char ch = *endp;
*endp = '\0';
strcpy(newpath, oldpath);
if (newpath[strlen(newpath)-1] != *delim) {
strcat(newpath, delim);
}
strcat(newpath, qualifiedpath);
*endp = ch;
strcat(newpath, endp);
}
} else {
/**
** No marker set
**/
if (append) {
strcpy(newpath, oldpath);
if (newpath[strlen(newpath)-1] != *delim) {
strcat(newpath, delim);
}
strcat(newpath, qualifiedpath);
} else {
strcpy(newpath, qualifiedpath);
if (*oldpath != *delim) {
strcat(newpath, delim);
}
strcat(newpath, oldpath);
} /* end "if (append)" */
} /** end "if (marker)" **/
} /** end "if (strcmp)" **/
/**
** Now the new value to be set resides in 'newpath'. Set it up.
**/
moduleSetenv(interp, (char *)argv[arg1], newpath, 1);
_TCLCHK(interp)
#if WITH_DEBUGGING_CALLBACK
ErrorLogger(NO_ERR_END, LOC, _proc_cmdSetPath, NULL);
#endif /* WITH_DEBUGGING_CALLBACK */
/**
** Free resources
**/
null_free((void *)&newpath);
success1:
null_free((void *)&oldpath);
null_free((void *)&qualifiedpath);
FreeList(pathlist, numpaths);
success0:
return (TCL_OK); /** -------- EXIT (SUCCESS) -------> **/
unwind2:
null_free((void *)&qualifiedpath);
unwind1:
FreeList(pathlist, numpaths);
unwind0:
null_free((void *)&oldpath);
return (TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
} /** End of 'cmdSetPath' **/
int main(
int argc,
char *argv[],
char *environ[]
) {
Tcl_Interp *interp;
int return_val = 0;
char *rc_name;
char *rc_path;
Tcl_Obj **objv; /** Tcl Object vector **/
int objc; /** Tcl Object vector count **/
#ifdef HAVE_SETLOCALE
/* set local via LC_ALL */
setlocale(LC_ALL, "");
#endif
#if ENABLE_NLS
/* the text message domain. */
bindtextdomain(PACKAGE, LOCALEDIR);
textdomain(PACKAGE);
#endif
/**
** check if first argument is --version or -V then output the
** version to stdout. This is a special circumstance handled
** by the regular options.
**/
if (argc > 1 && *argv[1] == '-') {
if (!strcmp("-V", argv[1]) || !strcmp("--version", argv[1])) {
version(stdout);
return 0;
}
}
/**
** Initialization.
**/
if (!(ModulePathVec = ModulePathList())) {
ModulePath = NULL;
/* goto unwind0; */
} else {
ModulePath = uvec_vector(ModulePathVec);
}
/**
** Check the command line syntax. There will be no return from the
** initialization function in case of invalid command line arguments.
**/
if (TCL_OK != Initialize_Module(&interp, argc, argv, environ))
goto unwind1;
if (TCL_OK != Setup_Environment(interp))
goto unwind1;
/**
** Check for command line switches
**/
if (TCL_OK != Check_Switches(&argc, argv))
goto unwind1;
/**
** Figure out, which global RC file to use. This depends on the environ-
** ment variable 'MODULERCFILE', which can be set to one of the following:
**
** <filename> --> SYSCONFDIR/<filename>
** <dir>/ --> <dir>/RC_FILE
** <dir>/<file> --> <dir>/<file>
** Use xgetenv to expand 1 level of env.vars.
**/
if ((rc_name = xgetenv("MODULERCFILE"))) {
/* found something in MODULERCFILE */
if (!(rc_path = stringer(NULL, 0, rc_name, NULL))) {
if (OK != ErrorLogger(ERR_STRING, LOC, NULL))
goto unwind2;
else
null_free((void *)&rc_name);
} else {
null_free((void *)&rc_name);
if (!(rc_name = strrchr(rc_path, *psep))) {
rc_name = rc_path;
rc_path = etcpath;
} else
*rc_name++ = '\0';
if (!*rc_name) {
rc_name = rc_file;
}
}
} else {
rc_path = stringer(NULL,0, etcpath, NULL);
null_free((void *)&rc_name);
rc_name = rc_file;
}
/**
** Source the global and the user defined RC file
**/
g_current_module = (char *)NULL;
if (TCL_ERROR == SourceRC(interp, rc_path, rc_name, Mod_Load) ||
TCL_ERROR == SourceRC(interp,getenv("HOME"),modulerc_file,Mod_Load))
exit(1);
if (rc_path)
null_free((void *)&rc_path);
/**
** Invocation of the module command as specified in the command line
**/
g_flags = 0;
Tcl_ArgvToObjv(&objc, &objv, argc - 1, argv + 1);
return_val = cmdModule((ClientData) 0, interp, objc, objv);
/**
** If we were doing some operation that has already flushed its output,
** then we don't need to re-flush the output here.
**
** Also, if we've had an error here, then the whole modulecmd failed
** and not just the values for a single modulefile. So, we'll pass in
** a NULL here to indicate that any error message should say that
** absolutely NO changes were made to the environment.
**/
if (TCL_OK == return_val) {
Output_Modulefile_Changes(interp);
#ifdef HAS_X11LIBS
xresourceFinish(1);
#endif
} else {
Unwind_Modulefile_Changes(interp, NULL);
#ifdef HAS_X11LIBS
xresourceFinish(0);
#endif
}
/**
** Finally clean up. Delete the required hash tables and conditionally
** allocated areas.
**/
Global_Hash_Tables(GHashDelete, NULL);
if (line)
null_free((void *)&line);
if (error_line)
null_free((void *)&error_line);
/**
** This return value may be evaluated by the calling shell
**/
OutputExit();
return (return_val ? return_val : g_retval);
/* unwind3:
null_free((void *) &rc_path); */
unwind2:
null_free((void *)&rc_name);
unwind1:
FreeList(&ModulePathVec);
unwind0:
/* and error occurred of some type */
g_retval = (g_retval ? g_retval : 1);
OutputExit();
return (g_retval);
} /** End of 'main' **/
static int Remove_Path(Tcl_Interp *interp, char *variable, char *item,
char *sw_marker, const char *delim)
{
char *oldpath, /** current path **/
*olditem; /** item from path **/
int i = 0, /** counter **/
found = 0, /** flag to indicate item was found **/
pcount = 0, /** count of items in path **/
addsep = 0, /** flag to add separator **/
marked = 0, /** flag path contains sw_marker **/
oldpathlen = 0;
Tcl_DString _newpath;
Tcl_DString *newpath = &_newpath;
Tcl_DStringInit(newpath);
/**
** Get the current value of the "PATH" environment variable
**/
oldpath = (char *)EMGetEnv(interp, variable);
if (!oldpath || !*oldpath) {
null_free((void *)&oldpath);
_TCLCHK(interp);
goto success0; /** -------- EXIT (SUCCESS) -------> **/
}
/* copy oldpath to not mess with the TCL value of env(PATH) */
if (!(oldpath = stringer(NULL,0, oldpath, NULL))) {
if (OK != ErrorLogger(ERR_STRING, LOC, NULL)) {
goto unwind0;
}
}
/* get length of oldpath before it gets modified by xstrtok */
oldpathlen = (int)strlen(oldpath);
/* determine if sw_marker is in the path */
olditem = xstrtok(oldpath, delim);
while (olditem) {
if (!strcmp(olditem, sw_marker)) {
marked = 1;
}
pcount++;
olditem = xstrtok(NULL, delim);
}
/** pointer arithmetic on oldpath
** if olditem starts at terminating null string of oldpath,
** it means the last character in oldpath was ":", meaning
** the last element was the empty string. use <= to catch
** this case and process the last empty element
*/
for (olditem = oldpath; olditem <= oldpath + oldpathlen;
olditem += strlen(olditem) + 1) {
if (strcmp(olditem, item)) {
/* not the droids we're looking for */
if (Tcl_DStringLength(newpath)) {
if (!Tcl_DStringAppend(newpath, delim, 1))
if (OK !=
ErrorLogger(ERR_STRING, LOC, NULL))
goto unwind1;
}
if (!Tcl_DStringAppend(newpath, olditem, -1))
if (OK != ErrorLogger(ERR_STRING, LOC, NULL))
goto unwind1;
} else {
/* bingo! Don't add it to new path */
found++;
if ((g_flags & M_SWSTATE1) && !marked) {
/**
** In state1, we're actually replacing old paths with
** the markers for future appends and prepends.
**
** We only want to do this once to mark the location
** the module was formed around.
**/
marked = 1;
if (Tcl_DStringLength(newpath)) {
if (!Tcl_DStringAppend
(newpath, delim, 1))
if (OK !=
ErrorLogger(ERR_STRING, LOC,
NULL))
goto unwind1;
}
if (!Tcl_DStringAppend(newpath, sw_marker, -1))
if (OK !=
ErrorLogger(ERR_STRING, LOC, NULL))
goto unwind1;
}
}
}
if (!found) {
goto success1;
}
if (Tcl_DStringLength(newpath)) {
/**
** Cache the set. Clear the variable from the unset table just
** in case it was previously unset.
**/
store_hash_value(setenvHashTable, variable,
Tcl_DStringValue(newpath));
clear_hash_value(unsetenvHashTable, variable);
/**
** Store the new PATH value into the environment.
**/
(void) EMSetEnv( interp, variable, Tcl_DStringValue(newpath));
_TCLCHK(interp);
} else {
/**
** In this case, I should go ahead and unset the variable
** from the environment because I'm removing the very last
** path.
**
** First I'm going to clear the variable from the
** setenvHashTable just in case its already been altered
** and had a significant value at the time. It's very
** possible that I'm removing the only two or three paths
** from this variable. If that's the case, then all the
** earlier paths were marked for output in this hashTable.
**
** Secondly, I actually mark the the environment variable
** to be unset when output.
**/
clear_hash_value(setenvHashTable, variable);
moduleUnsetenv(interp, variable);
/**
** moduleUnsetenv doesn't unset the variable in the Tcl
** space because the $env variable might need to be
** used again in the modulefile for locating other
** paths. BUT, since this was a path-type environment
** variable, the user is expecting this to be empty
** after removing the only remaining path. So, I set
** the variable empty here.
**/
(void) EMSetEnv( interp, variable, "");
_TCLCHK(interp);
}
/**
** Free what has been used and return on success
**/
success1:
null_free((void *)&oldpath);
success0:
Tcl_DStringFree(newpath);
return (TCL_OK); /** -------- EXIT (SUCCESS) -------> **/
unwind1:
null_free((void *)&oldpath);
unwind0:
Tcl_DStringFree(newpath);
return (TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
} /** End of 'Remove_Path' **/
bool
Block::can_extract_as (const symbol key, Attribute::type other_type) const
{
const Attribute::type my_type = lookup (key);
if (my_type == other_type)
return true;
// BUG: Sometimes you can extract a name from a number (scalars?)
if (my_type != Attribute::Model)
return false;
if (type_size (key) != Attribute::Singleton)
return false;
if (!check (key))
return false;
const Frame& frame = find_frame (key);
switch (other_type)
{
case Attribute::Number:
{
if (frame.component (key) != Number::component)
return false;
if (!frame.check (*this))
return false;
std::unique_ptr<Number> number (Librarian::build_frame<Number>
(*this, frame.model (key), key));
if (!number.get ())
return false;
if (!number->initialize (units (), *this, msg ()))
return false;
if (number->missing (*this))
return false;
return true;
}
case Attribute::String:
{
if (frame.component (key) != Stringer::component)
return false;
if (!frame.check (*this))
return false;
std::unique_ptr<Stringer> stringer (Librarian::build_frame<Stringer>
(*this, frame.model (key), key));
if (!stringer.get ())
return false;
if (!stringer->initialize (units (), *this, msg ()))
return false;
if (stringer->missing (*this))
return false;
return true;
}
case Attribute::Boolean:
{
if (frame.component (key) != Boolean::component)
return false;
if (!frame.check (*this))
return false;
std::unique_ptr<Boolean> boolean (Librarian::build_frame<Boolean>
(*this, frame.model (key), key));
if (!boolean.get ())
return false;
if (!boolean->initialize (units (), *this, msg ()))
return false;
if (boolean->missing (*this))
return false;
return true;
}
default:
return false;
}
}
int ModuleCmd_Update( Tcl_Interp *interp,
int count,
char *module_list[])
{
#ifdef BEGINENV
char *buf, /** Read buffer **/
*var_ptr, /** Pointer to a variables name **/
*val_ptr, /** Pointer to a variables value **/
**load_list, /** List of loaded modules **/
*tmpload, /** LOADEDMODULES contents **/
*loaded, /** Buffer for tokenization **/
*filename; /** The name of the file, where the **/
/** beginning environment resides **/
FILE *file; /** Handle to read in a file **/
int list_count = 0,
maxlist = 16, /** Max. number of list entries **/
buffer_size = UPD_BUFSIZE;
/** Current size of the input buffer **/
char *ptr, c; /** Read pointers and char buffer **/
# if BEGINENV == 99
if (!EMGetEnv( interp,"MODULESBEGINENV")) {
ErrorLogger( ERR_BEGINENVX, LOC, NULL);
return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
}
# endif
/**
** Nothing loaded so far - we're ready!
**/
if(!(tmpload = (char *) getenv("LOADEDMODULES"))) {
if( OK != ErrorLogger( ERR_MODULE_PATH, LOC, NULL))
goto unwind0;
else
goto success0;
}
/**
** First I'll update the environment with whatever in _MODULESBEGINENV_
**/
filename = EMGetEnv( interp,"_MODULESBEGINENV_");
if(filename && *filename) {
/**
** Read the begining environment
**/
if((file = fopen( filename, "r"))) {
if(!(buf = stringer(NULL, buffer_size, NULL )))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
goto unwind0;
while( !feof( file)) {
/**
** Trigger on entries of the type
** <variable> = <value>
**/
ptr = buf;
while( !feof( file)) {
if((ptr-buf) >= buffer_size-10) { /** 10 bytes safety **/
null_free((void *) &buf);
if(!(buf = stringer(NULL,
buffer_size += UPD_BUFSIZE, NULL )))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
goto unwind0;
}
/**
** Read a character and put it into the read buffer. Check
** for the lines (CR) or a terminator character ...
**/
if( '\n' == (*ptr++ = c = fgetc( file))) {
*ptr++ = c = '\0';
break;
}
if( !c)
break;
} /** while **/
/**
** If there hasn't been a terminator so far, put it at the
** end of the line. Therefor we've left a safety space at the
** buffers end ;-)
**/
if( c)
*ptr++ = '\0';
/**
** Now let's evaluate the read line
**/
if( (var_ptr = strchr( buf, '=')) ) {
*var_ptr = '\0';
val_ptr = var_ptr+1;
var_ptr = buf;
/**
** Reset the environment to the values derivered from the
** _MODULESBEGINENV_.
** Do not change the LOADEDMODULES variable ;-)
** Do not change the TCL_LIBRARY and TK_LIBRARY also.
**/
if( strncmp( var_ptr, "LOADEDMODULES", 12) &&
strncmp( var_ptr, "TCL_LIBRARY", 10 ) &&
strncmp( var_ptr, "TK_LIBRARY", 9 )) {
if( !strncmp( var_ptr, "MODULEPATH", 10))
moduleSetenv( interp, var_ptr, val_ptr, 1);
else
EMSetEnv( interp, var_ptr, val_ptr);
}
} /** if( var_ptr) **/
} /** while **/
/**
** Close the _MODULESBEGINENV_ file anf free up the read buffer.
**/
null_free((void *) &buf);
if( EOF == fclose( file))
if( OK != ErrorLogger( ERR_CLOSE, LOC, filename, NULL))
goto unwind0;
} else { /** if( fopen) **/
if( OK != ErrorLogger( ERR_OPEN, LOC, filename,_(em_reading),NULL))
goto unwind0;
} /** if( fopen) **/
} /** if( filename) **/
null_free((void *) &filename);
/**
** Allocate memory for a buffer to tokenize the list of loaded modules
** and a list buffer
**/
if(!(load_list = (char**) module_malloc( maxlist*sizeof(char**))))
if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
goto unwind0;
if(!(loaded = stringer(NULL, 0, tmpload, NULL)))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
goto unwind1;
/**
** Tokenize and build the list
**/
if( *loaded) {
for( load_list[ list_count++] = xstrtok( loaded, ":");
load_list[ list_count-1];
load_list[ list_count++] = xstrtok( NULL, ":") ) {
/**
** Conditionally we have to double the space, we've allocated for
** the list
**/
if( list_count >= maxlist) {
maxlist = maxlist<<1;
if(!(load_list = (char**) module_realloc(
(char *) load_list, maxlist*sizeof(char**))))
if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
goto unwind1;
} /** if( maxlist) **/
} /** for **/
/**
** Load all the modules in the list
**/
ModuleCmd_Load( interp, 1, list_count, load_list);
}
/**
** Free up what has been allocated and return on success
**/
null_free((void *) &loaded);
null_free((void *) &load_list);
success0:
return( TCL_OK); /** -------- EXIT (SUCCESS) -------> **/
unwind1:
null_free((void *) &load_list);
unwind0:
null_free((void *) &filename);
#else /* BEGINENV */
ErrorLogger( ERR_BEGINENV, LOC, NULL);
#endif /* !BEGINENV */
return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
} /** End of 'ModuleCmd_Update' **/
static int checkConflict(
Tcl_Interp * interp,
char *path,
char **modulelist,
unsigned int nummodules
) {
uvec *new_modulelist;
int new_nummodules, k;
is_Result fstate;
char *buffer;
memset(error_module, '\0', MOD_BUFSIZE);
/**
** Check all modules passed to me as parameter
** At first clarify if they really do exist ...
**/
for (k = 0; k < nummodules; k++) {
if (!(buffer = stringer(NULL,0,path,psep,modulelist[k],NULL)))
if (OK != ErrorLogger(ERR_STRING, LOC, NULL))
goto unwind0;
if (!(fstate = is_("what", buffer))) {
if (OK != ErrorLogger(ERR_FILEINDIR, LOC,
modulelist[k], path, NULL))
if (!stringer(error_module, MOD_BUFSIZE,
modulelist[k], NULL))
if (OK !=
ErrorLogger(ERR_STRING, LOC, NULL))
goto unwind1;
goto unwind1;
}
/**
** Is it a directory what has been passed? If it is, list the
** according directory and call myself recursively in order to
**/
if (fstate == IS_DIR) {
if (!(new_modulelist = SortedDirList(path,
modulelist[k], &new_nummodules)))
continue;
if (TCL_ERROR == checkConflict(interp, path,
uvec_vector(new_modulelist), new_nummodules)) {
FreeList(&new_modulelist);
goto unwind1;
}
FreeList(&new_modulelist);
/**
** If it isn't a directory, check the current one for to be the
** required module file
**/
} else {
if (IsLoaded_ExactMatch (interp,modulelist[k],NULL,NULL)
&& strcmp(g_current_module, modulelist[k])) {
/**
** Save the name of the offending module in a buffer
** for reporting purposes when we get back to the top.
**/
if (!stringer(error_module, MOD_BUFSIZE,
modulelist[k], NULL))
if (OK !=
ErrorLogger(ERR_STRING, LOC, NULL))
goto unwind1;
goto unwind1;
}
} /** if( directory) **/
} /** for **/
/**
** free resources
**/
null_free((void *)&buffer);
return (TCL_OK); /** -------- EXIT (SUCCESS) -------> **/
unwind1:
null_free((void *)&buffer);
unwind0:
return (TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
} /** End of 'checkConflict' **/
int SourceVers( Tcl_Interp *interp, char *path, char *name)
{
struct stat stats; /** Buffer for the stat() systemcall **/
int save_flags;
char *buffer;
char *modname; /** ptr to module part of name **/
int Result = TCL_OK;
char *version;
char *new_argv[3];
char *mod, *ver;
/**
** If there's a problem with the input parameters it means, that
** we do not have to source anything
** Only a valid TCL interpreter should be there
**/
if( !path || !name)
return( TCL_OK);
if( !interp)
return( TCL_ERROR);
/**
** Build the full name of the RC file and check whether it exists and
** has the magic cookie inside
**/
if ((char *) NULL == (buffer = stringer(NULL, 0, path,"/",version_file,
NULL)))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
return( TCL_ERROR);
if( !stat( buffer, &stats)) {
if(
#if VERSION_MAGIC != 0
check_magic( buffer, MODULES_MAGIC_COOKIE,
MODULES_MAGIC_COOKIE_LENGTH)
#else
1
#endif
) {
save_flags = g_flags;
g_flags = M_LOAD;
if( TCL_ERROR != (Result = Execute_TclFile( interp, buffer)) &&
(version = (char *) Tcl_GetVar(interp, "ModulesVersion", 0))) {
/**
** The version has been specified in the
** '.version' file. Set up the result code
**/
/* for deep modulefile dirs ... just use lowest part */
if (!(modname = (char*) strrchr( name, '/'))) {
modname = name;
} else {
modname++;
}
null_free((void *) &buffer);
if ((char *) NULL == (buffer = stringer(NULL, 0,
modname,"/",version, NULL)))
if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
return( TCL_ERROR);
new_argv[0] = "module-version";
new_argv[1] = buffer;
new_argv[2] = _default;
/**
** Define the default version
**/
if( TCL_OK != cmdModuleVersion( (ClientData) 0,
(Tcl_Interp *) NULL, 3, (CONST84 char **) new_argv)) {
Result = TCL_ERROR;
}
} /** if( Execute...) **/
g_flags = save_flags;
} else
ErrorLogger( ERR_MAGIC, LOC, buffer, NULL);
} /** if( !stat) **/
/**
** free buffer memory
**/
null_free((void *) &buffer);
/**
** Result determines if this was successful
**/
return( Result);
} /** End of 'SourceVers' **/