1 | /*****
2 | ** ** Module Header ******************************************************* **
3 | ** **
4 | ** Modules Revision 3.0 **
5 | ** Providing a flexible user environment **
6 | ** **
7 | ** File: cmdModule.c **
8 | ** First Edition: 91/10/23 **
9 | ** **
10 | ** Authors: John Furlan, jlf@behere.com **
11 | ** Jens Hamisch, jens@Strawberry.COM **
12 | ** **
13 | ** Description: The actual module command from the Tcl level. This **
14 | ** routines calls other ModuleCmd routines to carry out **
15 | ** the subcommand requested. **
16 | ** **
17 | ** Exports: cmdModule **
18 | ** Read_Modulefile **
19 | ** Execute_TclFile **
20 | ** CallModuleProcedure **
21 | ** **
22 | ** Notes: **
23 | ** **
24 | ** ************************************************************************ **
25 | ****/
26 |
27 | /** ** Copyright *********************************************************** **
28 | ** **
29 | ** Copyright 1991-1994 by John L. Furlan. **
30 | ** see LICENSE.GPL, which must be provided, for details **
31 | ** **
32 | ** ************************************************************************ **/
33 |
34 | static char Id[] = "@(#)$Id: cmdModule.c.src.html,v 1.1 2005/11/15 03:43:35 rkowen Exp $";
35 | static void *UseId[] = { &UseId, Id };
36 |
37 | /** ************************************************************************ **/
38 | /** HEADERS **/
39 | /** ************************************************************************ **/
40 |
41 | #include "modules_def.h"
42 |
43 | /** ************************************************************************ **/
44 | /** LOCAL DATATYPES **/
45 | /** ************************************************************************ **/
46 |
47 | /** not applicable **/
48 |
49 | /** ************************************************************************ **/
50 | /** CONSTANTS **/
51 | /** ************************************************************************ **/
52 |
53 | /** not applicable **/
54 |
55 | /** ************************************************************************ **/
56 | /** MACROS **/
57 | /** ************************************************************************ **/
58 |
59 | /** not applicable **/
60 |
61 | /** ************************************************************************ **/
62 | /** LOCAL DATA **/
63 | /** ************************************************************************ **/
64 |
65 | char _fil_stdin[] = "stdin";
66 | char _fil_stdout[] = "stdout";
67 | char _fil_stderr[] = "stderr";
68 | char _fil_devnull[] = "/dev/null";
69 |
70 | int linenum = 0;
71 |
72 | static char module_name[] = "cmdModule.c"; /** File name of this module **/
73 |
74 | #if WITH_DEBUGGING_CALLBACK
75 | static char _proc_cmdModule[] = "cmdModule";
76 | #endif
77 | #if WITH_DEBUGGING_UTIL
78 | static char _proc_Read_Modulefile[] = "Read_Modulefile";
79 | #endif
80 | #if WITH_DEBUGGING_UTIL_1
81 | static char _proc_Execute_TclFile[] = "Execute_TclFile";
82 | static char _proc_CallModuleProcedure[] = "CallModuleProcedure";
83 | #endif
84 |
85 | char *module_command;
86 |
87 | /** ************************************************************************ **/
88 | /** PROTOTYPES **/
89 | /** ************************************************************************ **/
90 |
91 | /** not applicable **/
92 |
93 |
94 | /*++++
95 | ** ** Function-Header ***************************************************** **
96 | ** **
97 | ** Function: cmdModule **
98 | ** **
99 | ** Description: Evaluation of the module command line and callup of **
100 | ** the according subroutine **
101 | ** **
102 | ** First Edition: 91/10/23 **
103 | ** **
104 | ** Parameters: ClientData client_data **
105 | ** Tcl_Interp *interp According Tcl interp.**
106 | ** int argc Number of arguments **
107 | ** char *argv[] Argument array **
108 | ** **
109 | ** Result: int TCL_OK Successfull completion **
110 | ** TCL_ERROR Any error **
111 | ** **
112 | ** Attached Globals: g_flags These are set up accordingly before **
113 | ** this function is called in order to **
114 | ** control everything **
115 | ** g_current_module The module which is handled **
116 | ** by the current command **
117 | ** **
118 | ** ************************************************************************ **
119 | ++++*/
120 |
121 | int cmdModule( ClientData client_data,
122 | Tcl_Interp *interp,
123 | int argc,
124 | char *argv[])
125 | {
126 | int return_val = -1, i;
127 | int store_flags = g_flags;
128 | char *store_curmodule = NULL;
129 | char *save_module_command = NULL;
130 | #ifdef FORCE_PATH
131 | char *base_path = NULL;
132 | char *sacred_path = NULL;
133 | #endif
134 | int match = 0;
135 |
136 | /**
137 | ** These skip the arguments past the shell and command.
138 | **/
139 |
140 | int num_modulefiles = argc - 2;
141 | char **modulefile_list = argv + 2;
142 |
143 | #if 0
144 | int x=0;
145 | # define _XD fprintf(stderr,":%d:",++x),
146 | #else
147 | # define _XD
148 | #endif
149 |
150 | #define _MTCH _XD match =
151 | #define _ISERR ((match == -1) && (*interp->result))
152 |
153 | #if WITH_DEBUGGING_CALLBACK
154 | ErrorLogger( NO_ERR_START, LOC, _proc_cmdModule, NULL);
155 | #endif
156 |
157 | /**
158 | ** Help or whatis mode?
159 | **/
160 |
161 | if( g_flags & (M_HELP | M_WHATIS))
162 | return( TCL_OK);
163 |
164 | /**
165 | ** Parameter check
166 | **/
167 |
168 | if( argc < 2) {
169 | (void) ErrorLogger( ERR_USAGE, LOC, "module", " command ",
170 | " [arguments ...] ", NULL);
171 | (void) ModuleCmd_Help( interp, 0, modulefile_list);
172 | return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
173 | }
174 |
175 | /**
176 | ** Display whatis mode?
177 | **/
178 |
179 | if( g_flags & M_DISPLAY) {
180 | fprintf( stderr, "%s\t\t ", argv[ 0]);
181 | for( i=1; i<argc; i++)
182 | fprintf( stderr, "%s ", argv[ i]);
183 | fprintf( stderr, "\n");
184 | return( TCL_OK);
185 | }
186 |
187 | /**
188 | ** For recursion. This can be called multiple times.
189 | **/
190 |
191 | save_module_command = module_command;
192 | module_command = strdup( argv[1]);
193 |
194 | if( g_current_module)
195 | store_curmodule = g_current_module;
196 |
197 | /**
198 | ** If the command is '-', we want to just start
199 | ** interpreting Tcl from stdin.
200 | **/
201 |
202 | if(_XD !strcmp( module_command, "-")) {
203 | return_val = Execute_TclFile( interp, _fil_stdin);
204 |
205 | /**
206 | ** Evaluate the module command and call the according subroutine
207 | ** --- module LOAD|ADD
208 | **/
209 |
210 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command, addRE)) {
211 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
212 | return_val = ModuleCmd_Load( interp, 1,num_modulefiles,modulefile_list);
213 |
214 | #ifdef FORCE_PATH
215 | if( return_val) {
216 |
217 | /**
218 | ** return_val now indicates whether ANY modulefile was loaded
219 | ** Only if any modulefile was loaded do we need to worry
220 | ** about forcing paths.
221 | **/
222 |
223 | if( base_path = (char *) getenv( "MODULES_PATH_BASE") ||
224 | base_path = (char *) getenv( "BASE_PATH")) {
225 | ForceBasePath( interp, "PATH", base_path);
226 | } else {
227 | ForceBasePath( interp, "PATH", FORCE_PATH);
228 | }
229 |
230 | if( sacred_path = (char *) getenv( "MODULES_PATH_SACRED") ||
231 | sacred_path = (char *) getenv( "SACRED_PATH")) {
232 | ForceSacredPath( interp, "PATH", sacred_path);
233 | } else {
234 | ForceSacredPath( interp, "PATH", FORCE_PATH_SACRED);
235 | }
236 |
237 | if(sacred_path = (char *) getenv("MODULES_LD_LIBRARY_PATH_SACRED")){
238 | ForceSacredPath( interp, "LD_LIBRARY_PATH", sacred_path);
239 | } else {
240 | ForceSacredPath( interp, "LD_LIBRARY_PATH",
241 | FORCE_LD_LIBRARY_PATH_SACRED);
242 | }
243 |
244 | } /** if( return_val) **/
245 | #endif
246 |
247 | /**
248 | ** We always say the load succeeded. ModuleCmd_Load will
249 | ** output any necessary error messages.
250 | **/
251 |
252 | return_val = TCL_OK;
253 |
254 | /**
255 | ** --- module UNLOAD
256 | **/
257 |
258 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command, rmRE)) {
259 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
260 | ModuleCmd_Load( interp, 0, num_modulefiles, modulefile_list);
261 | return_val = TCL_OK;
262 |
263 | /**
264 | ** --- module SWITCH
265 | **/
266 |
267 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command, swRE)) {
268 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
269 | return_val = ModuleCmd_Switch( interp, num_modulefiles,modulefile_list);
270 |
271 | /**
272 | ** --- module DISPLAY
273 | **/
274 |
275 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command, dispRE)) {
276 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
277 | return_val = ModuleCmd_Display( interp,num_modulefiles,modulefile_list);
278 |
279 | /**
280 | ** --- module LIST
281 | **/
282 |
283 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command, listRE)) {
284 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
285 | if (! (sw_format & SW_SET) ) { /* default format options */
286 | sw_format |= (SW_HUMAN | SW_TERSE );
287 | sw_format &= ~(SW_PARSE | SW_LONG );
288 | }
289 | /* use SW_LIST to indicate LIST & not AVAIL */
290 | sw_format |= SW_LIST;
291 | return_val = ModuleCmd_List( interp, num_modulefiles, modulefile_list);
292 |
293 | /**
294 | ** --- module AVAIL
295 | **/
296 |
297 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command,availRE)) {
298 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
299 | if (! (sw_format & SW_SET) ) { /* default format options */
300 | sw_format |= (SW_HUMAN | SW_TERSE);
301 | sw_format &= ~(SW_PARSE | SW_LONG );
302 | }
303 | /* use SW_LIST to indicate LIST & not AVAIL */
304 | sw_format &= ~SW_LIST;
305 | return_val = ModuleCmd_Avail( interp, num_modulefiles, modulefile_list);
306 |
307 | /**
308 | ** --- module WHATIS and APROPOS
309 | **/
310 |
311 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command,whatisRE)) {
312 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
313 | return_val = ModuleCmd_Whatis(interp, num_modulefiles, modulefile_list);
314 |
315 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command,aproposRE)) {
316 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
317 | return_val = ModuleCmd_Apropos(interp, num_modulefiles,modulefile_list);
318 |
319 | /**
320 | ** --- module CLEAR
321 | **/
322 |
323 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command,clearRE)) {
324 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
325 | return_val = ModuleCmd_Clear( interp, num_modulefiles, modulefile_list);
326 |
327 | /**
328 | ** --- module UPDATE
329 | **/
330 |
331 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command,updateRE)) {
332 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
333 | return_val = ModuleCmd_Update(interp, num_modulefiles, modulefile_list);
334 |
335 | /**
336 | ** --- module PURGE
337 | **/
338 |
339 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command,purgeRE)) {
340 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
341 | return_val = ModuleCmd_Purge( interp, num_modulefiles, modulefile_list);
342 |
343 | /**
344 | ** --- module INIT
345 | **/
346 |
347 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command,initRE)) {
348 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
349 |
350 | if( Tcl_RegExpMatch(interp,module_command, "^inita|^ia")){/* initadd */
351 | if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
352 | g_flags |= M_LOAD;
353 | return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
354 | g_flags &= ~M_LOAD;
355 | }
356 |
357 | if( Tcl_RegExpMatch(interp,module_command, "^initr|^iw")){ /* initrm */
358 | if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
359 | g_flags |= M_REMOVE;
360 | return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
361 | g_flags &= ~M_REMOVE;
362 | }
363 |
364 | if( Tcl_RegExpMatch(interp,module_command, "^initl|^il")){/* initlist*/
365 | if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
366 | g_flags |= M_DISPLAY;
367 | return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
368 | g_flags &= ~M_DISPLAY;
369 | }
370 |
371 | if(Tcl_RegExpMatch(interp,module_command, "^inits|^is")){/* initswitch*/
372 | if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
373 | g_flags |= M_SWITCH;
374 | return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
375 | g_flags &= ~M_SWITCH;
376 | }
377 |
378 | if(Tcl_RegExpMatch(interp,module_command, "^initc|^ic")){/* initclear*/
379 | if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
380 | g_flags |= M_CLEAR;
381 | return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
382 | g_flags &= ~M_CLEAR;
383 | }
384 |
385 | if(Tcl_RegExpMatch(interp,module_command,"^initp|^ip")){/*initprepend*/
386 | if (_ISERR) ErrorLogger(ERR_EXEC,LOC,interp->result,NULL);
387 | g_flags |= (M_PREPEND | M_LOAD);
388 | return_val = ModuleCmd_Init(interp,num_modulefiles,modulefile_list);
389 | g_flags &= ~(M_PREPEND | M_LOAD);
390 | }
391 |
392 | /**
393 | ** --- module USE
394 | **/
395 |
396 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command, useRE)) {
397 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
398 | return_val = ModuleCmd_Use( interp, num_modulefiles, modulefile_list);
399 |
400 | /**
401 | ** --- module UNUSE
402 | **/
403 |
404 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command, unuseRE)) {
405 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
406 | return_val = ModuleCmd_UnUse( interp, num_modulefiles, modulefile_list);
407 |
408 | /**
409 | ** --- module HELP
410 | **/
411 |
412 | } else if(_MTCH Tcl_RegExpMatch(interp,module_command, helpRE)) {
413 | if (_ISERR) ErrorLogger( ERR_EXEC, LOC, interp->result, NULL);
414 | return_val = ModuleCmd_Help( interp, num_modulefiles, modulefile_list);
415 | }
416 |
417 | /**
418 | ** Tracing
419 | **/
420 |
421 | if( CheckTracingList(interp, module_command,
422 | num_modulefiles, modulefile_list))
423 | Module_Tracing( return_val, argc, argv);
424 |
425 | /**
426 | ** Evaluate the subcommands return value in order to get rid of unrecog-
427 | ** nized commands
428 | **/
429 |
430 | if( return_val < 0)
431 | if( OK != ErrorLogger( ERR_COMMAND, LOC, module_command, NULL))
432 | return (TCL_ERROR);
433 |
434 | /**
435 | ** Clean up from recursion
436 | **/
437 |
438 | g_flags = store_flags;
439 | if( store_curmodule)
440 | g_current_module = store_curmodule;
441 |
442 | module_command = save_module_command;
443 |
444 | /**
445 | ** Return on success
446 | **/
447 |
448 | #if WITH_DEBUGGING_CALLBACK
449 | ErrorLogger( NO_ERR_END, LOC, _proc_cmdModule, NULL);
450 | #endif
451 |
452 | return( return_val);
453 |
454 | } /** End of 'cmdModule' **/
455 |
456 | /*++++
457 | ** ** Function-Header ***************************************************** **
458 | ** **
459 | ** Function: Read_Modulefile **
460 | ** **
461 | ** Description: Check the passed filename for to be a valid module **
462 | ** and execute the according command file **
463 | ** **
464 | ** First Edition: 91/10/23 **
465 | ** **
466 | ** Parameters: Tcl_Interp *interp According Tcl interp.**
467 | ** char *filename **
468 | ** **
469 | ** Result: int TCL_OK Successfull completion **
470 | ** TCL_ERROR Any error **
471 | ** **
472 | ** Attached Globals: **
473 | ** **
474 | ** ************************************************************************ **
475 | ++++*/
476 |
477 | int Read_Modulefile( Tcl_Interp *interp,
478 | char *filename)
479 | {
480 | int result;
481 | char *startp, *endp;
482 |
483 | #if WITH_DEBUGGING_UTIL
484 | ErrorLogger( NO_ERR_START, LOC, _proc_Read_Modulefile, NULL);
485 | #endif
486 |
487 | /**
488 | ** Parameter check. A valid filename is to be given.
489 | **/
490 |
491 | if( !filename) {
492 | if( OK != ErrorLogger( ERR_PARAM, LOC, "filename", NULL))
493 | return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
494 | }
495 |
496 | /**
497 | ** Check for the module 'magic cookie'
498 | ** Trust stdin as a valid module file ...
499 | **/
500 |
501 | if( !strcmp( filename, _fil_stdin) && !check_magic( filename,
502 | MODULES_MAGIC_COOKIE, MODULES_MAGIC_COOKIE_LENGTH)) {
503 | if( OK != ErrorLogger( ERR_MAGIC, LOC, filename, NULL))
504 | return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
505 | }
506 |
507 | /**
508 | ** Now do execute that module file and evaluate the result of the
509 | ** latest executed command
510 | **/
511 |
512 | if( TCL_ERROR == (result = Execute_TclFile(interp, filename))) {
513 |
514 | #if WITH_DEBUGGING_UTIL
515 | ErrorLogger( NO_ERR_DEBUG, LOC, "Execution of '",
516 | filename, "' failed", NULL);
517 | #endif
518 |
519 | if( *interp->result) {
520 | char *tstr = NULL;
521 | Tcl_RegExp retexpPtr;
522 |
523 | tstr = strdup(interp->result);
524 | retexpPtr = Tcl_RegExpCompile(interp, "^EXIT ([0-9]*)");
525 | if( Tcl_RegExpExec(interp, retexpPtr, tstr, tstr)) {
526 | Tcl_RegExpRange(retexpPtr, 1, &startp, &endp);
527 | if( startp != '\0')
528 | result = atoi( startp );
529 | }
530 | if (tstr)
531 | null_free((void *) &tstr);
532 | }
533 | }
534 |
535 | /**
536 | ** Return the result as derivered from the module file execution
537 | **/
538 |
539 | #if WITH_DEBUGGING_UTIL
540 | ErrorLogger( NO_ERR_END, LOC, _proc_Read_Modulefile, NULL);
541 | #endif
542 |
543 | return( result);
544 |
545 | } /** End of 'Read_Modulefile' **/
546 |
547 | /*++++
548 | ** ** Function-Header ***************************************************** **
549 | ** **
550 | ** Function: Execute_TclFile **
551 | ** **
552 | ** Description: Read in and execute all commands concerning the Tcl **
553 | ** file passed as parameter **
554 | ** **
555 | ** First Edition: 91/10/23 **
556 | ** **
557 | ** Parameters: Tcl_Interp *interp According Tcl interp.**
558 | ** char *filename **
559 | ** **
560 | ** Result: int TCL_OK Successfull completion **
561 | ** TCL_ERROR Any error **
562 | ** **
563 | ** Attached Globals: line Input read buffer **
564 | ** **
565 | ** ************************************************************************ **
566 | ++++*/
567 |
568 | int Execute_TclFile( Tcl_Interp *interp,
569 | char *filename)
570 | {
571 | FILE *infile;
572 | int gotPartial = 0;
573 | int result = 0;
574 | char *cmd;
575 | Tcl_DString cmdbuf;
576 |
577 | #if WITH_DEBUGGING_UTIL_1
578 | ErrorLogger( NO_ERR_START, LOC, _proc_Execute_TclFile, NULL);
579 | #endif
580 |
581 | /**
582 | ** If there isn't a line buffer allocated so far, do it now
583 | **/
584 |
585 | if( line == NULL) {
586 | if( NULL == (line = (char*) malloc( LINELENGTH * sizeof( char)))) {
587 | if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
588 | return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
589 | }
590 | }
591 |
592 | /**
593 | ** If we're supposed to be interpreting from stdin, set infile
594 | ** equal to stdin, otherwise, open the file and interpret
595 | **/
596 |
597 | if( !strcmp( filename, _fil_stdin)) {
598 | infile = stdin;
599 | } else {
600 | if( NULL == (infile = fopen( filename, "r"))) {
601 | if( OK != ErrorLogger( ERR_OPEN, LOC, filename, "reading", NULL))
602 | return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
603 | }
604 | }
605 |
606 | /**
607 | ** Allow access to which file is being loaded.
608 | **/
609 |
610 | linenum = 0;
611 | Tcl_SetVar( interp, "ModulesCurrentModulefile", filename, 0);
612 | Tcl_DStringInit( &cmdbuf);
613 |
614 | while( 1) {
615 |
616 | linenum++;
617 | if( fgets(line, LINELENGTH, infile) == NULL) {
618 | if( !gotPartial) {
619 | break; /** while **/
620 | }
621 | line[0] = '\0';
622 | }
623 |
624 | /**
625 | ** Put the whole command on the command buffer
626 | **/
627 |
628 | cmd = Tcl_DStringAppend( &cmdbuf, line, (-1));
629 |
630 | if( line[0] != 0 && !Tcl_CommandComplete(cmd)) {
631 | gotPartial++;
632 | continue;
633 | }
634 |
635 | /**
636 | ** Now evaluate the command and react on its result
637 | ** Reinitialize the command buffer
638 | **/
639 |
640 | #if WITH_DEBUGGING_UTIL_1
641 | ErrorLogger( NO_ERR_DEBUG, LOC, " Evaluating '", cmd, "'", NULL);
642 | #endif
643 |
644 | result = Tcl_Eval( interp, cmd);
645 |
646 | if( TCL_ERROR == result) {
647 | ErrorLogger( ERR_EXEC, LOC, cmd, NULL);
648 | }
649 |
650 | Tcl_DStringTrunc( &cmdbuf, 0);
651 |
652 | #if WITH_DEBUGGING_UTIL_1
653 | {
654 | char buffer[ 80];
655 |
656 | switch( result) {
657 | case TCL_OK: strcpy( buffer, "TCL_OK");
658 | break;
659 |
660 | case TCL_ERROR: strcpy( buffer, "TCL_ERROR");
661 | break;
662 |
663 | case TCL_LEVEL0_RETURN:
664 | strcpy( buffer, "TCL_LEVEL0_RETURN");
665 | break;
666 | }
667 |
668 | ErrorLogger( NO_ERR_DEBUG, LOC, " Result: '", buffer, "'", NULL);
669 | }
670 | #endif
671 |
672 | switch( result) {
673 |
674 | case TCL_OK: gotPartial = 0;
675 | continue; /** while **/
676 |
677 | case TCL_ERROR: interp->errorLine = ((linenum-1)-gotPartial) +
678 | interp->errorLine;
679 | /* FALLTHROUGH */
680 |
681 | case TCL_LEVEL0_RETURN:
682 | break; /** switch **/
683 | }
684 |
685 | /**
686 | ** If the while loop hasn't been continued so far, it is to be broken
687 | ** now
688 | **/
689 |
690 | break; /** while **/
691 |
692 | } /** while **/
693 |
694 | /**
695 | ** Free up what has been used, close the input file and return the result
696 | ** of the last command to the caller
697 | **/
698 |
699 | Tcl_DStringFree( &cmdbuf);
700 | if( EOF == fclose( infile))
701 | if( OK != ErrorLogger( ERR_CLOSE, LOC, filename, NULL))
702 | return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
703 |
704 | #if WITH_DEBUGGING_UTIL_1
705 | ErrorLogger( NO_ERR_END, LOC, _proc_Execute_TclFile, NULL);
706 | #endif
707 |
708 | return( result);
709 |
710 | } /** End of 'Execute_TclFile' **/
711 |
712 | /*++++
713 | ** ** Function-Header ***************************************************** **
714 | ** **
715 | ** Function: CallModuleProcedure **
716 | ** **
717 | ** Description: Call a Tcl Procedure **
718 | ** Executes the passed modulefile (conditionally hidden)**
719 | ** and then evaluates the passed Tcl procedure **
720 | ** **
721 | ** First Edition: 91/10/23 **
722 | ** **
723 | ** Parameters: Tcl_Interp *interp According Tcl interp.**
724 | ** Tcl_DString *cmdptr Buffer fot the Tcl **
725 | ** command **
726 | ** char *modulefile According module file**
727 | ** char *procname Name of the Tcl Proc.**
728 | ** int suppress_output Controlls redirect.**
729 | ** of stdout and stderr **
730 | ** **
731 | ** Result: int TCL_OK Successfull completion **
732 | ** TCL_ERROR Any error **
733 | ** **
734 | ** Attached Globals: - **
735 | ** **
736 | ** ************************************************************************ **
737 | ++++*/
738 |
739 | int CallModuleProcedure( Tcl_Interp *interp,
740 | Tcl_DString *cmdptr,
741 | char *modulefile,
742 | char *procname,
743 | int suppress_output)
744 | {
745 | char cmdline[ LINELENGTH];
746 | char *cmd;
747 | int result;
748 | int saved_stdout = 0, saved_stderr = 0, devnull;
749 |
750 | #if WITH_DEBUGGING_UTIL_1
751 | ErrorLogger( NO_ERR_START, LOC, _proc_CallModuleProcedure, NULL);
752 | #endif
753 |
754 | /**
755 | ** Must send stdout and stderr to /dev/null until the
756 | ** ModulesHelp procedure is called.
757 | **/
758 |
759 | if( suppress_output) {
760 | if( 0 > (devnull = open( _fil_devnull, O_RDWR))) {
761 | if( OK != ErrorLogger( ERR_OPEN, LOC, _fil_devnull, "changing", NULL))
762 | return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
763 | }
764 |
765 | /**
766 | ** Close STDOUT and reopen it as /dev/null
767 | **/
768 |
769 | if( -1 == ( saved_stdout = dup( 1)))
770 | if( OK != ErrorLogger( ERR_DUP, LOC, _fil_stdout, NULL))
771 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
772 |
773 | if( -1 == close( 1))
774 | if( OK != ErrorLogger( ERR_CLOSE, LOC, _fil_stdout, NULL))
775 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
776 |
777 | if( -1 == dup( devnull))
778 | if( OK != ErrorLogger( ERR_DUP, LOC, _fil_devnull, NULL))
779 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
780 |
781 | /**
782 | ** Close STDERR and reopen it as /dev/null
783 | **/
784 |
785 | if( -1 == ( saved_stdout = dup( 2)))
786 | if( OK != ErrorLogger( ERR_DUP, LOC, _fil_stderr, NULL))
787 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
788 |
789 | if( -1 == close( 2))
790 | if( OK != ErrorLogger( ERR_CLOSE, LOC, _fil_stderr, NULL))
791 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
792 |
793 | if( -1 == dup( devnull))
794 | if( OK != ErrorLogger( ERR_DUP, LOC, _fil_devnull, NULL))
795 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
796 | }
797 |
798 | /**
799 | ** Read the passed module file
800 | **/
801 |
802 | Read_Modulefile( interp, modulefile);
803 |
804 | /**
805 | ** Reinstall stdout and stderr
806 | **/
807 |
808 | if( suppress_output) {
809 |
810 | /**
811 | ** Reinstall STDOUT
812 | **/
813 |
814 | if( EOF == fflush( stdout))
815 | if( OK != ErrorLogger( ERR_FLUSH, LOC, _fil_stdout, NULL))
816 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
817 |
818 | if( EOF == fflush( stderr))
819 | if( OK != ErrorLogger( ERR_FLUSH, LOC, _fil_stderr, NULL))
820 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
821 |
822 | if( -1 == close( 1))
823 | if( OK != ErrorLogger( ERR_CLOSE, LOC, _fil_stdout, NULL))
824 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
825 |
826 | /**
827 | ** Reinstall STDERR
828 | **/
829 |
830 | if( -1 == dup( saved_stdout))
831 | if( OK != ErrorLogger( ERR_DUP, LOC, _fil_stdout, NULL))
832 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
833 |
834 | if( -1 == close( 2))
835 | if( OK != ErrorLogger( ERR_CLOSE, LOC, _fil_stderr, NULL))
836 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
837 |
838 | if( -1 == dup( saved_stderr))
839 | if( OK != ErrorLogger( ERR_DUP, LOC, _fil_stderr, NULL))
840 | return( TCL_ERROR); /** ------- EXIT (FAILURE) --------> **/
841 | }
842 |
843 | /**
844 | ** Now evaluate the Tcl Procedure
845 | **/
846 |
847 | /* sprintf( cmdline, "%s\n", procname); */
848 | strcpy( cmdline, procname);
849 | strcat( cmdline, "\n");
850 | cmd = Tcl_DStringAppend( cmdptr, cmdline, (-1));
851 |
852 | result = Tcl_Eval( interp, cmd);
853 | Tcl_DStringTrunc( cmdptr, 0);
854 |
855 | #if WITH_DEBUGGING_UTIL_1
856 | ErrorLogger( NO_ERR_END, LOC, _proc_CallModuleProcedure, NULL);
857 | #endif
858 |
859 | return( result);
860 |
861 | } /** End of 'CallModuleProcedure' **/