1 /*****
2 ** ** Module Header ******************************************************* **
3 ** **
4 ** Modules Revision 3.0 **
5 ** Providing a flexible user environment **
6 ** **
7 ** File: utility.c **
8 ** First Edition: 1991/10/23 **
9 ** **
10 ** Authors: John Furlan, jlf@behere.com **
11 ** Jens Hamisch, jens@Strawberry.COM **
12 ** **
13 ** Description: General routines that are called throughout Modules **
14 ** which are not necessarily specific to any single **
15 ** block of functionality. **
16 ** **
17 ** Exports: store_hash_value **
18 ** clear_hash_value **
19 ** Delete_Global_Hash_Tables **
20 ** Delete_Hash_Tables **
21 ** Copy_Hash_Tables **
22 ** Unwind_Modulefile_Changes **
23 ** Output_Modulefile_Changes **
24 ** IsLoaded_ExactMatch **
25 ** IsLoaded **
26 ** chk_marked_entry **
27 ** set_marked_entry **
28 ** Update_LoadedList **
29 ** check_magic **
30 ** regex_quote **
31 ** xstrtok **
32 ** xstrtok_r **
33 ** chk4spch **
34 ** module_malloc **
35 ** xdup **
36 ** xgetenv **
37 ** stringer **
38 ** null_free **
39 ** countTclHash **
40 ** **
41 ** strdup if not defined by the system libs. **
42 ** **
43 ** Notes: **
44 ** **
45 ** ************************************************************************ **
46 ****/
47
48 /** ** Copyright *********************************************************** **
49 ** **
50 ** Copyright 1991-1994 by John L. Furlan. **
51 ** see LICENSE.GPL, which must be provided, for details **
52 ** **
53 ** ************************************************************************ **/
54
55 static char Id[] = "@(#)$Id: b16f29ec6f608bcbdc99e5e329befefbd7fa43fb $";
56 static void *UseId[] = { &UseId, Id };
57
58 /** ************************************************************************ **/
59 /** HEADERS **/
60 /** ************************************************************************ **/
61
62 #include "modules_def.h"
63
64 /** ************************************************************************ **/
65 /** LOCAL DATATYPES **/
66 /** ************************************************************************ **/
67
68 /** not applicable **/
69
70 /** ************************************************************************ **/
71 /** CONSTANTS **/
72 /** ************************************************************************ **/
73
74 /** not applicable **/
75
76 /** ************************************************************************ **/
77 /** MACROS **/
78 /** ************************************************************************ **/
79
80 /** not applicable **/
81
82 /** ************************************************************************ **/
83 /** LOCAL DATA **/
84 /** ************************************************************************ **/
85
86 static char module_name[] = "utility.c"; /** File name of this module **/
87
88 #if WITH_DEBUGGING_UTIL_2
89 static char _proc_store_hash_value[] = "store_hash_value";
90 static char _proc_clear_hash_value[] = "clear_hash_value";
91 static char _proc_Clear_Global_Hash_Tables[] = "Clear_Global_Hash_Tables";
92 static char _proc_Delete_Global_Hash_Tables[] = "Delete_Global_Hash_Tables";
93 static char _proc_Delete_Hash_Tables[] = "Delete_Hash_Tables";
94 static char _proc_Copy_Hash_Tables[] = "Copy_Hash_Tables";
95 static char _proc_Unwind_Modulefile_Changes[] = "Unwind_Modulefile_Changes";
96 static char _proc_Output_Modulefile_Changes[] = "Output_Modulefile_Changes";
97 static char _proc_Output_Modulefile_Aliases[] = "Output_Modulefile_Aliases";
98 static char _proc_Output_Directory_Change[] = "Output_Directory_Change";
99 static char _proc_output_set_variable[] = "output_set_variable";
100 static char _proc_output_unset_variable[] = "output_unset_variable";
101 static char _proc_output_function[] = "output_function";
102 static char _proc_output_set_alias[] = "output_set_alias";
103 static char _proc_output_unset_alias[] = "output_unset_alias";
104 static char _proc_getLMFILES[] = "getLMFILES";
105 static char _proc___IsLoaded[] = "__IsLoaded";
106 static char _proc_chk_marked_entry[] = "chk_marked_entry";
107 static char _proc_set_marked_entry[] = "set_marked_entry";
108 static char _proc_get_module_basename[] = "get_module_basename";
109 static char _proc_Update_LoadedList[] = "Update_LoadedList";
110 static char _proc_check_magic[] = "check_magic";
111 static char _proc_cleanse_path[] = "cleanse_path";
112 static char _proc_chop[] = "chop";
113 #endif
114
115 static FILE *aliasfile; /** Temporary file to write aliases **/
116 static char *aliasfilename; /** Temporary file name **/
117 static char alias_separator = ';'; /** Alias command separator **/
118 static const int eval_alias = /** EVAL_ALIAS macro **/
119 #ifdef EVAL_ALIAS
120 1
121 #else
122 0
123 #endif
124 ;
125 static const int bourne_funcs = /** HAS_BOURNE_FUNCS macro **/
126 #ifdef HAS_BOURNE_FUNCS
127 1
128 #else
129 0
130 #endif
131 ;
132 static const int bourne_alias = /** HAS_BOURNE_FUNCS macro **/
133 #ifdef HAS_BOURNE_ALIAS
134 1
135 #else
136 0
137 #endif
138 ;
139
140 /** ************************************************************************ **/
141 /** PROTOTYPES **/
142 /** ************************************************************************ **/
143
144 static void Clear_Global_Hash_Tables( void);
145 static int Output_Modulefile_Aliases( Tcl_Interp *interp);
146 static int Output_Directory_Change(Tcl_Interp *interp);
147 static int output_set_variable( Tcl_Interp *interp, const char*,
148 const char*);
149 static int output_unset_variable( const char* var);
150 static void output_function( const char*, const char*);
151 static int output_set_alias( const char*, const char*);
152 static int output_unset_alias( const char*, const char*);
153 static int __IsLoaded( Tcl_Interp*, char*, char**, char*, int);
154 static char *get_module_basename( char*);
155 static char *chop( const char*);
156 static void EscapeCshString(const char* in,
157 char* out);
158 static void EscapeShString(const char* in,
159 char* out);
160 static void EscapePerlString(const char* in,
161 char* out);
162 static void EscapeCmakeString(const char* in,
163 char* out);
164
165
166 /*++++
167 ** ** Function-Header ***************************************************** **
168 ** **
169 ** Function: store_hash_value **
170 ** **
171 ** Description: Keeps the old value of the variable around if it is **
172 ** touched in the modulefile to enable undoing a **
173 ** modulefile by resetting the evironment to it started.**
174 ** **
175 ** This is the same for unset_shell_variable() **
176 ** **
177 ** First Edition: 1992/10/14 **
178 ** **
179 ** Parameters: Tcl_HashTable *htable Hash table to be used**
180 ** const char *key Attached key **
181 ** const char *value Alias value **
182 ** **
183 ** Result: int TCL_OK Successful completion **
184 ** **
185 ** Attached Globals: - **
186 ** **
187 ** ************************************************************************ **
188 ++++*/
189
store_hash_value(Tcl_HashTable * htable,const char * key,const char * value)190 int store_hash_value( Tcl_HashTable* htable,
191 const char* key,
192 const char* value)
193 {
194 int new; /** Return from Tcl_CreateHashEntry **/
195 /** which indicates creation or ref- **/
196 /** ference to an existing entry **/
197 char *tmp; /** Temp pointer used for disalloc. **/
198 Tcl_HashEntry *hentry; /** Hash entry reference **/
199
200 #if WITH_DEBUGGING_UTIL_2
201 ErrorLogger( NO_ERR_START, LOC, _proc_store_hash_value, NULL);
202 #endif
203
204 /**
205 ** Create a hash entry for the key to be stored. If there exists one
206 ** so far, its value has to be unlinked.
207 ** All values in this hash are pointers to allocated memory areas.
208 **/
209
210 hentry = Tcl_CreateHashEntry( htable, (char*) key, &new);
211 if( !new) {
212 tmp = (char *) Tcl_GetHashValue( hentry);
213 if( tmp)
214 null_free((void *) &tmp);
215 }
216
217 /**
218 ** Set up the new value. strdup allocates!
219 **/
220
221 if( value)
222 Tcl_SetHashValue( hentry, (char*) stringer(NULL,0, (char *)value,NULL));
223 else
224 Tcl_SetHashValue( hentry, (char*) NULL);
225
226 return( TCL_OK);
227
228 } /** End of 'store_hash_value' **/
229
230 /*++++
231 ** ** Function-Header ***************************************************** **
232 ** **
233 ** Function: clear_hash_value **
234 ** **
235 ** Description: Remove the specified shell variable from the passed **
236 ** hash table **
237 ** **
238 ** First Edition: 1991/10/23 **
239 ** **
240 ** Parameters: Tcl_HashTable *htable Hash table to be used**
241 ** const char *key Attached key **
242 ** **
243 ** Result: int TCL_OK Successful completion **
244 ** **
245 ** Attached Globals: - **
246 ** **
247 ** ************************************************************************ **
248 ++++*/
249
clear_hash_value(Tcl_HashTable * htable,const char * key)250 int clear_hash_value( Tcl_HashTable *htable,
251 const char *key)
252 {
253 char *tmp; /** Temp pointer used for dealloc. **/
254 Tcl_HashEntry *hentry; /** Hash entry reference **/
255
256 #if WITH_DEBUGGING_UTIL_2
257 ErrorLogger( NO_ERR_START, LOC, _proc_clear_hash_value, NULL);
258 #endif
259
260 /**
261 ** If I haven't already created an entry for keeping this environment
262 ** variable's value, then just leave.
263 ** Otherwise, remove this entry from the hash table.
264 **/
265
266 if( hentry = Tcl_FindHashEntry( htable, (char*) key) ) {
267
268 tmp = (char*) Tcl_GetHashValue( hentry);
269 if( tmp)
270 null_free((void *) &tmp);
271
272 Tcl_DeleteHashEntry( hentry);
273 }
274
275 return( TCL_OK);
276
277 } /** End of 'clear_hash_value' **/
278
279 /*++++
280 ** ** Function-Header ***************************************************** **
281 ** **
282 ** Function: Clear_Global_Hash_Tables **
283 ** **
284 ** Description: Deletes and reinitializes our env. hash tables. **
285 ** **
286 ** First Edition: 1992/10/14 **
287 ** **
288 ** Parameters: - **
289 ** Result: - **
290 ** **
291 ** Attached Globals: setenvHashTable, **
292 ** unsetenvHashTable, **
293 ** aliasSetHashTable, **
294 ** aliasUnsetHashTable **
295 ** **
296 ** ************************************************************************ **
297 ++++*/
298
Clear_Global_Hash_Tables(void)299 static void Clear_Global_Hash_Tables( void)
300 {
301 Tcl_HashSearch searchPtr; /** Tcl hash search handle **/
302 Tcl_HashEntry *hashEntry; /** Result from Tcl hash search **/
303 char *val = NULL; /** Stored value (is a pointer!) **/
304
305 /**
306 ** The following hash tables are to be initialized
307 **/
308
309 Tcl_HashTable *table[5],
310 **table_ptr = table;
311
312 table[0] = setenvHashTable;
313 table[1] = unsetenvHashTable;
314 table[2] = aliasSetHashTable;
315 table[3] = aliasUnsetHashTable;
316 table[4] = NULL;
317
318 #if WITH_DEBUGGING_UTIL_2
319 ErrorLogger( NO_ERR_START, LOC, _proc_Clear_Global_Hash_Tables, NULL);
320 #endif
321
322 /**
323 ** Loop for all the hash tables named above. If there's no value stored
324 ** in a hash table, skip to the next one.
325 **/
326
327 for( ; *table_ptr; table_ptr++) {
328
329 if( ( hashEntry = Tcl_FirstHashEntry( *table_ptr, &searchPtr)) == NULL)
330 continue;
331
332 /**
333 ** Otherwise remove all values stored in the table
334 **/
335
336 do {
337 val = (char*) Tcl_GetHashValue( hashEntry);
338 if( val)
339 null_free((void *) &val);
340 } while( hashEntry = Tcl_NextHashEntry( &searchPtr));
341
342 /**
343 ** Reinitialize the hash table by unlocking it from memory and
344 ** thereafter initializing it again.
345 **/
346
347 Tcl_DeleteHashTable( *table_ptr);
348 Tcl_InitHashTable( *table_ptr, TCL_STRING_KEYS);
349
350 } /** for **/
351
352 } /** End of 'Clear_Global_Hash_Tables' **/
353
354 /*++++
355 ** ** Function-Header ***************************************************** **
356 ** **
357 ** Function: Delete_Global_Hash_Tables **
358 ** Delete_Hash_Tables **
359 ** **
360 ** Description: Deletes our environment hash tables. **
361 ** **
362 ** First Edition: 1992/10/14 **
363 ** **
364 ** Parameters: Tcl_HashTable **table_ptr NULL-Terminated list **
365 ** of hash tables to be **
366 ** deleted **
367 ** Result: - **
368 ** **
369 ** Attached Globals: setenvHashTable, **
370 ** unsetenvHashTable, **
371 ** aliasSetHashTable, **
372 ** aliasUnsetHashTable **
373 ** **
374 ** ************************************************************************ **
375 ++++*/
376
Delete_Global_Hash_Tables(void)377 void Delete_Global_Hash_Tables( void) {
378
379 /**
380 ** The following hash tables are to be initialized
381 **/
382
383 Tcl_HashTable *table[5];
384
385 table[0] = setenvHashTable;
386 table[1] = unsetenvHashTable;
387 table[2] = aliasSetHashTable;
388 table[3] = aliasUnsetHashTable;
389 table[4] = NULL;
390
391 #if WITH_DEBUGGING_UTIL_2
392 ErrorLogger( NO_ERR_START, LOC, _proc_Delete_Global_Hash_Tables, NULL);
393 #endif
394
395 Delete_Hash_Tables( table);
396
397 } /** End of 'Delete_Global_Hash_Tables' **/
398
Delete_Hash_Tables(Tcl_HashTable ** table_ptr)399 void Delete_Hash_Tables( Tcl_HashTable **table_ptr)
400 {
401
402 Tcl_HashSearch searchPtr; /** Tcl hash search handle **/
403 Tcl_HashEntry *hashEntry; /** Result from Tcl hash search **/
404 char *val = NULL; /** Stored value (is a pointer!) **/
405
406 #if WITH_DEBUGGING_UTIL_2
407 ErrorLogger( NO_ERR_START, LOC, _proc_Delete_Hash_Tables, NULL);
408 #endif
409
410 /**
411 ** Loop for all the hash tables named above. Remove all values stored in
412 ** the table and then free up the whole table
413 **/
414 for( ; *table_ptr; table_ptr++) {
415
416 if( ( hashEntry = Tcl_FirstHashEntry( *table_ptr, &searchPtr))) {
417
418 /**
419 ** Remove all values stored in the table
420 **/
421 do {
422 val = (char*) Tcl_GetHashValue( hashEntry);
423 if( val)
424 null_free((void *) &val);
425 } while( hashEntry = Tcl_NextHashEntry( &searchPtr));
426
427 /**
428 ** Remove internal hash control structures
429 **/
430 Tcl_DeleteHashTable( *table_ptr);
431 }
432
433 null_free((void *) table_ptr);
434
435 } /** for **/
436
437 #if WITH_DEBUGGING_UTIL_2
438 ErrorLogger( NO_ERR_END, LOC, _proc_Delete_Hash_Tables, NULL);
439 #endif
440
441 } /** End of 'Delete_Hash_Tables' **/
442
443 /*++++
444 ** ** Function-Header ***************************************************** **
445 ** **
446 ** Function: Copy_Hash_Tables **
447 ** **
448 ** Description: Allocate new hash tables for the global environment, **
449 ** initialize them and copy the contents of the current **
450 ** tables into them. **
451 ** **
452 ** First Edition: 1991/10/23 **
453 ** **
454 ** Parameters: - **
455 ** Result: Tcl_HashTable** Pointer to the new list of **
456 ** hash tables **
457 ** Attached Globals: setenvHashTable, **
458 ** unsetenvHashTable, **
459 ** aliasSetHashTable, **
460 ** aliasUnsetHashTable **
461 ** **
462 ** ************************************************************************ **
463 ++++*/
464
Copy_Hash_Tables(void)465 Tcl_HashTable **Copy_Hash_Tables( void)
466 {
467 Tcl_HashSearch searchPtr; /** Tcl hash search handle **/
468 Tcl_HashEntry *oldHashEntry, /** Hash entries to be copied **/
469 *newHashEntry;
470 char *val = NULL, /** Stored value (is a pointer!) **/
471 *key = NULL; /** Hash key **/
472 int new; /** Tcl inidicator, if the new hash **/
473 /** entry has been created or ref. **/
474
475 Tcl_HashTable *oldTable[5],
476 **o_ptr, **n_ptr,
477 **newTable; /** Destination hash table **/
478
479 oldTable[0] = setenvHashTable;
480 oldTable[1] = unsetenvHashTable;
481 oldTable[2] = aliasSetHashTable;
482 oldTable[3] = aliasUnsetHashTable;
483 oldTable[4] = NULL;
484
485 #if WITH_DEBUGGING_UTIL_2
486 ErrorLogger( NO_ERR_START, LOC, _proc_Copy_Hash_Tables, NULL);
487 #endif
488
489 /**
490 ** Allocate storage for the new list of hash tables
491 **/
492 if( !(newTable = (Tcl_HashTable**) module_malloc( sizeof( oldTable))))
493 if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
494 goto unwind0;
495
496 /**
497 ** Now copy each hashtable out of the list
498 **/
499 for( o_ptr = oldTable, n_ptr = newTable; *o_ptr; o_ptr++, n_ptr++) {
500
501 /**
502 ** Allocate memory for a single hash table
503 **/
504 if( !(*n_ptr = (Tcl_HashTable*) module_malloc( sizeof( Tcl_HashTable))))
505 if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
506 goto unwind1;
507
508 /**
509 ** Initialize that guy and copy it from the old table
510 **/
511 Tcl_InitHashTable( *n_ptr, TCL_STRING_KEYS);
512 if( oldHashEntry = Tcl_FirstHashEntry( *o_ptr, &searchPtr)) {
513
514 /**
515 ** Copy all entries if there are any
516 **/
517 do {
518
519 key = (char*) Tcl_GetHashKey( *o_ptr, oldHashEntry);
520 val = (char*) Tcl_GetHashValue( oldHashEntry);
521
522 newHashEntry = Tcl_CreateHashEntry( *n_ptr, key, &new);
523
524 if(val)
525 Tcl_SetHashValue(newHashEntry, stringer(NULL,0, val, NULL));
526 else
527 Tcl_SetHashValue(newHashEntry, (char *) NULL);
528
529 } while( oldHashEntry = Tcl_NextHashEntry( &searchPtr));
530
531 } /** if **/
532 } /** for **/
533
534 /**
535 ** Put a terminator at the end of the new table
536 **/
537 *n_ptr = NULL;
538
539 #if WITH_DEBUGGING_UTIL_2
540 ErrorLogger( NO_ERR_END, LOC, _proc_Copy_Hash_Tables, NULL);
541 #endif
542
543 return( newTable);
544
545 unwind1:
546 null_free((void *) &newTable);
547 unwind0:
548 return( NULL); /** -------- EXIT (FAILURE) -------> **/
549 } /** End of 'Copy_Hash_Tables' **/
550
551 /*++++
552 ** ** Function-Header ***************************************************** **
553 ** **
554 ** Function: **
555 ** **
556 ** Description: Once a the loading or unloading of a modulefile **
557 ** fails, any changes it has made to the environment **
558 ** must be undone and reset to its previous state. This **
559 ** function is responsible for unwinding any changes a **
560 ** modulefile has made. **
561 ** **
562 ** First Edition: 1991/10/23 **
563 ** **
564 ** Parameters: Tcl_Interp *interp According TCL interp.**
565 ** Tcl_HashTable **oldTables Hash tables storing **
566 ** the former environm. **
567 ** Result: **
568 ** Attached Globals: **
569 ** **
570 ** ************************************************************************ **
571 ++++*/
572
Unwind_Modulefile_Changes(Tcl_Interp * interp,Tcl_HashTable ** oldTables)573 int Unwind_Modulefile_Changes( Tcl_Interp *interp,
574 Tcl_HashTable **oldTables )
575 {
576 Tcl_HashSearch searchPtr; /** Tcl hash search handle **/
577 Tcl_HashEntry *hashEntry; /** Result from Tcl hash search **/
578 char *val = NULL, /** Stored value (is a pointer!) **/
579 *key; /** Tcl hash key **/
580 int i; /** Loop counter **/
581
582 #if WITH_DEBUGGING_UTIL_2
583 ErrorLogger( NO_ERR_START, LOC, _proc_Unwind_Modulefile_Changes, NULL);
584 #endif
585
586 if( oldTables) {
587
588 /**
589 ** Use only entries 0 and 1 which do contain all changes to the
590 ** shell varibles (setenv and unsetenv)
591 **/
592
593 /** ??? What about the aliases (table 2 and 3) ??? **/
594
595 for( i = 0; i < 2; i++) {
596 if( hashEntry = Tcl_FirstHashEntry( oldTables[i], &searchPtr)) {
597
598 do {
599 key = (char*) Tcl_GetHashKey( oldTables[i], hashEntry);
600
601 /**
602 ** The hashEntry will contain the appropriate value for the
603 ** specified 'key' because it will have been aquired depending
604 ** upon whether the unset or set table was used.
605 **/
606
607 val = (char*) Tcl_GetHashValue( hashEntry);
608 if( val)
609 EMSetEnv( interp, key, val);
610
611 } while( hashEntry = Tcl_NextHashEntry( &searchPtr) );
612
613 } /** if **/
614 } /** for **/
615
616 /**
617 ** Delete and reset the hash tables now that the current contents have been
618 ** flushed.
619 **/
620
621 Delete_Global_Hash_Tables();
622
623 setenvHashTable = oldTables[0];
624 unsetenvHashTable = oldTables[1];
625 aliasSetHashTable = oldTables[2];
626 aliasUnsetHashTable = oldTables[3];
627
628 } else {
629
630 Clear_Global_Hash_Tables();
631
632 }
633
634 return( TCL_OK);
635
636 } /** End of 'Unwind_Modulefile_Changes' **/
637
keycmp(const void * a,const void * b)638 static int keycmp(const void *a, const void *b) {
639 return strcmp(*(const char **) a, *(const char **) b);
640 }
641
642 /*++++
643 ** ** Function-Header ***************************************************** **
644 ** **
645 ** Function: Output_Modulefile_Changes **
646 ** **
647 ** Description: Is used to flush out the changes of the current **
648 ** modulefile in a manner depending upon whether the **
649 ** modulefile was successful or unsuccessful. **
650 ** **
651 ** First Edition: 1991/10/23 **
652 ** **
653 ** Parameters: Tcl_Interp *interp The attached Tcl in- **
654 ** terpreter **
655 ** **
656 ** Result: int TCL_OK Successful operation **
657 ** **
658 ** Attached Globals: setenvHashTable, **
659 ** unsetenvHashTable, **
660 ** aliasSetHashTable, via Output_Modulefile_Aliases**
661 ** aliasUnsetHashTable via Output_Modulefile_Aliases**
662 ** change_dir for the chdir command **
663 ** **
664 ** ************************************************************************ **
665 ++++*/
666
Output_Modulefile_Changes(Tcl_Interp * interp)667 int Output_Modulefile_Changes( Tcl_Interp *interp)
668 {
669 Tcl_HashSearch searchPtr; /** Tcl hash search handle **/
670 Tcl_HashEntry *hashEntry; /** Result from Tcl hash search **/
671 char *val = NULL, /** Stored value (is a pointer!) **/
672 *key, /** Tcl hash key **/
673 **list; /** list of keys **/
674 int i,k; /** Loop counter **/
675 size_t hcnt; /** count of hash entries **/
676
677 /**
678 ** The following hash tables do contain all changes to be made on
679 ** shell variables
680 **/
681
682 Tcl_HashTable *table[2];
683
684 table[0] = setenvHashTable;
685 table[1] = unsetenvHashTable;
686
687 #if WITH_DEBUGGING_UTIL_2
688 ErrorLogger( NO_ERR_START, LOC, _proc_Output_Modulefile_Changes, NULL);
689 #endif
690
691 aliasfile = stdout;
692
693 /**
694 ** Scan both tables that are of interest for shell variables
695 **/
696
697 for(i = 0; i < 2; i++) {
698 /* count hash */
699 hcnt = countTclHash(table[i]);
700
701 /* allocate array for keys */
702 if( !(list = (char **) module_malloc(hcnt * sizeof(char *)))) {
703 if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
704 return(TCL_ERROR);/** ------- EXIT (FAILURE) ------> **/
705 }
706
707 /* collect keys */
708 k = 0;
709 if( hashEntry = Tcl_FirstHashEntry( table[i], &searchPtr))
710 do {
711 key = (char*) Tcl_GetHashKey( table[i], hashEntry);
712 list[k++] = stringer(NULL,0, key, NULL);
713 } while( hashEntry = Tcl_NextHashEntry( &searchPtr));
714 /* sort hash */
715 if (hcnt > 1)
716 qsort((void *) list, hcnt, sizeof(char *), keycmp);
717
718 /* output key/values */
719 for (k = 0; k < hcnt; ++k) {
720 key = list[k];
721 hashEntry = Tcl_FindHashEntry( table[i], key);
722 /**
723 ** The table list indicator is used in order to differ
724 ** between the setenv and unsetenv operation
725 **/
726 if( i == 1) {
727 output_unset_variable( (char*) key);
728 } else {
729 val = EMGetEnv(interp, key);
730 if(val)
731 output_set_variable(interp, (char*) key, val);
732 null_free((void *)&val);
733 }
734 } /** for **/
735 /* delloc list */
736 for (k = 0; k < hcnt; ++k)
737 free(list[k]);
738 free(list);
739 } /** for **/
740
741 if( EOF == fflush( stdout))
742 if( OK != ErrorLogger( ERR_FLUSH, LOC, _fil_stdout, NULL))
743 return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
744
745 Output_Modulefile_Aliases( interp);
746 Output_Directory_Change( interp);
747
748 /**
749 ** Delete and reset the hash tables since the current contents have been
750 ** flushed.
751 **/
752
753 Clear_Global_Hash_Tables();
754 return( TCL_OK);
755
756 } /* End of 'Output_Modulefile_Changes' */
757
758 /*++++
759 ** ** Function-Header ***************************************************** **
760 ** **
761 ** Function: Open_Aliasfile **
762 ** **
763 ** Description: Creates/opens or closes temporary file for sourcing **
764 ** or aliases. **
765 ** Passes back the filehandle and filename in global **
766 ** variables. **
767 ** **
768 ** First Edition: 2005/09/26 R.K.Owen <rk@owen.sj.ca.us> **
769 ** **
770 ** Parameters: int action if != 0 to open else close **
771 ** **
772 ** Result: int TCL_OK Successful operation **
773 ** **
774 ** Attached Globals: aliasfile **
775 ** aliasfilename **
776 ** **
777 ** ************************************************************************ **
778 ++++*/
779
Open_Aliasfile(int action)780 static int Open_Aliasfile(int action)
781 {
782 if (action) {
783 /**
784 ** Open the file ...
785 **/
786 if( tmpfile_mod(&aliasfilename,&aliasfile))
787 if(OK != ErrorLogger( ERR_OPEN, LOC, aliasfilename, "append", NULL))
788 return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
789 } else {
790 if( EOF == fclose( aliasfile))
791 if( OK != ErrorLogger( ERR_CLOSE, LOC, aliasfilename, NULL))
792 return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
793 }
794
795 return( TCL_OK);
796
797 } /** End of 'Open_Aliasfile' **/
798 /*++++
799 ** ** Function-Header ***************************************************** **
800 ** **
801 ** Function: Output_Modulefile_Aliases **
802 ** **
803 ** Description: Is used to flush out the changes to the aliases of **
804 ** the current modulefile. But, some shells don't work **
805 ** well with having their alias information set via the **
806 ** 'eval' command. So, what we'll do now is output the **
807 ** aliases into a /tmp dotfile, have the shell source **
808 ** the /tmp dotfile and then have the shell remove the **
809 ** /tmp dotfile. **
810 ** **
811 ** First Edition: 1991/10/23 **
812 ** **
813 ** Parameters: Tcl_Interp *interp The attached Tcl in- **
814 ** terpreter **
815 ** **
816 ** Result: int TCL_OK Successful operation **
817 ** **
818 ** Attached Globals: aliasSetHashTable, via Output_Modulefile_Aliases**
819 ** aliasUnsetHashTable via Output_Modulefile_Aliases**
820 ** **
821 ** ************************************************************************ **
822 ++++*/
823
Output_Modulefile_Aliases(Tcl_Interp * interp)824 static int Output_Modulefile_Aliases( Tcl_Interp *interp)
825 {
826 Tcl_HashSearch searchPtr; /** Tcl hash search handle **/
827 Tcl_HashEntry *hashEntry; /** Result from Tcl hash search **/
828 char *val = NULL, /** Stored value (is a pointer!) **/
829 *key; /** Tcl hash key **/
830 int i, /** Loop counter **/
831 openfile = 0; /** whether using a file or not **/
832 char *sourceCommand; /** Command used to source the alias **/
833
834 /**
835 ** The following hash tables do contain all changes to be made on
836 ** shell aliases
837 **/
838 Tcl_HashTable *table[2];
839
840 table[0] = aliasSetHashTable;
841 table[1] = aliasUnsetHashTable;
842
843 /**
844 ** If configured so, all changes to aliases are written into a temporary
845 ** file which is sourced by the invoking shell ...
846 ** In this case a temporary filename has to be assigned for the alias
847 ** source file. The file has to be opened as 'aliasfile'.
848 ** The default for aliasfile, if no shell sourcing is used, is stdout.
849 **/
850
851 #if WITH_DEBUGGING_UTIL_2
852 ErrorLogger( NO_ERR_START, LOC, _proc_Output_Modulefile_Aliases, NULL);
853 #endif
854
855 /**
856 ** We only need to output stuff into a temporary file if we're setting
857 ** stuff. We can unset variables and aliases by just using eval.
858 **/
859 if( hashEntry = Tcl_FirstHashEntry( aliasSetHashTable, &searchPtr)) {
860
861 /**
862 ** We must use an aliasfile if EVAL_ALIAS is not defined
863 ** or the sh shell does not do aliases (HAS_BOURNE_ALIAS)
864 ** and that the sh shell does do functions (HAS_BOURNE_FUNCS)
865 **/
866 if (!eval_alias
867 || (!strcmp(shell_name,"sh") && !bourne_alias && bourne_funcs)) {
868 if (OK != Open_Aliasfile(1))
869 if(OK != ErrorLogger(ERR_OPEN,LOC,aliasfilename,"append",NULL))
870 return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
871 openfile = 1;
872 }
873 /**
874 ** We only support sh and csh variants for aliases. If not either
875 ** sh or csh print warning message and return
876 **/
877 assert(shell_derelict != NULL);
878 if( !strcmp( shell_derelict, "csh")) {
879 sourceCommand = "source %s%s";
880 } else if( !strcmp( shell_derelict, "sh")) {
881 sourceCommand = ". %s%s";
882 } else {
883 return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
884 }
885
886 if (openfile) {
887 /**
888 ** Only the source command has to be flushed to stdout. After
889 ** sourcing the alias definition (temporary) file, the source
890 ** file is to be removed.
891 **/
892 alias_separator = '\n';
893
894 fprintf( stdout, sourceCommand, aliasfilename, shell_cmd_separator);
895 fprintf( stdout, "/bin/rm -f %s%s",
896 aliasfilename, shell_cmd_separator);
897 } /** openfile **/
898 } /** if( alias to set) **/
899
900 /**
901 ** Scan the hash tables involved in changing aliases
902 **/
903
904 for( i=0; i<2; i++) {
905
906 if( hashEntry = Tcl_FirstHashEntry( table[i], &searchPtr)) {
907
908 do {
909 key = (char*) Tcl_GetHashKey( table[i], hashEntry);
910 val = (char*) Tcl_GetHashValue( hashEntry);
911
912 /**
913 ** The hashtable list index is used to differ between aliases
914 ** to be set and aliases to be reset
915 **/
916 if(i == 1) {
917 output_unset_alias( key, val);
918 } else {
919 output_set_alias( key, val);
920 }
921
922 } while( hashEntry = Tcl_NextHashEntry( &searchPtr));
923
924 } /** if **/
925 } /** for **/
926
927
928 if(openfile) {
929 if( OK != Open_Aliasfile(0))
930 if( OK != ErrorLogger( ERR_CLOSE, LOC, aliasfilename, NULL))
931 return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
932
933 null_free((void *) &aliasfilename);
934 }
935
936 return( TCL_OK);
937
938 } /** End of 'Output_Modulefile_Aliases' **/
939
940 /*++++
941 ** ** Function-Header ***************************************************** **
942 ** **
943 ** Function: Output_Directory_Change **
944 ** **
945 ** Description: Changes the current working directory. **
946 ** **
947 ** Parameters: Tcl_Interp *interp The attached Tcl interpreter **
948 ** **
949 ** Result: int TCL_OK Successful operation **
950 ** TCL_ERROR When not applicable **
951 ** **
952 ** Attached Global: change_dir **
953 ** **
954 ** ************************************************************************ **
955 ++++*/
Output_Directory_Change(Tcl_Interp * interp)956 static int Output_Directory_Change(Tcl_Interp *interp)
957 {
958 int rc = TCL_OK;
959
960 if (change_dir == NULL)
961 return rc;
962
963 assert(shell_derelict != NULL);
964 if(!strcmp(shell_derelict, "csh") || !strcmp(shell_derelict, "sh")) {
965 fprintf(stdout, "cd '%s'%s", change_dir, shell_cmd_separator);
966 } else if(!strcmp( shell_derelict, "perl")) {
967 fprintf(stdout, "chdir '%s'%s", change_dir, shell_cmd_separator);
968 } else if( !strcmp( shell_derelict, "python")) {
969 fprintf(stdout, "os.chdir('%s')\n", change_dir);
970 } else if( !strcmp( shell_derelict, "ruby")) {
971 fprintf(stdout, "Dir.chdir('%s')\n", change_dir);
972 } else {
973 rc = TCL_ERROR;
974 }
975
976 free(change_dir);
977 change_dir = NULL;
978
979 return rc;
980 }
981
982
983 /*++++
984 ** ** Function-Header ***************************************************** **
985 ** **
986 ** Function: output_set_variable **
987 ** **
988 ** Description: Outputs the command required to set a shell variable **
989 ** according to the current shell **
990 ** **
991 ** First Edition: 1991/10/23 **
992 ** **
993 ** Parameters: Tcl_Interp *interp The attached Tcl interpreter **
994 ** const char *var Name of the variable to be **
995 ** set **
996 ** const char *val Value to be assigned **
997 ** **
998 ** Result: int TCL_OK Finished successful **
999 ** TCL_ERROR Unknown shell type **
1000 ** **
1001 ** Attached Globals: shell_derelict **
1002 ** **
1003 ** ************************************************************************ **
1004 ++++*/
1005
output_set_variable(Tcl_Interp * interp,const char * var,const char * val)1006 static int output_set_variable( Tcl_Interp *interp,
1007 const char *var,
1008 const char *val)
1009 {
1010
1011 /**
1012 ** Differ between the different kinds od shells at first
1013 **
1014 ** CSH
1015 **/
1016 chop( val);
1017 chop( var);
1018
1019 assert(shell_derelict != NULL);
1020 #if WITH_DEBUGGING_UTIL_2
1021 ErrorLogger( NO_ERR_START, LOC, _proc_output_set_variable, " var='", var,
1022 "' val= '", val, "'", NULL);
1023 #endif
1024
1025 if( !strcmp((char*) shell_derelict, "csh")) {
1026
1027 #ifdef LMSPLIT_SIZE
1028
1029 /**
1030 ** Many C Shells (specifically the Sun one) has a hard limit on
1031 ** the size of the environment variables around 1k. The
1032 ** _LMFILES_ variable can grow beyond 1000 characters. So, I'm
1033 ** going to break it up here since I can put it back together
1034 ** again when I use it.
1035 **
1036 ** You can set the split size using --with-split-size=<number>
1037 ** it should probably be <1000. I don't count the size of
1038 ** "setenv _LMFILES_xxx" so subtract this from your limit.
1039 **/
1040 if( !strcmp( var, "_LMFILES_")) {
1041 char formatted[ MOD_BUFSIZE];
1042 char *cptr = NULL;
1043 int lmfiles_len;
1044 int count = 0;
1045 char* escaped = stringer(NULL,strlen(val)*2+1,NULL);
1046 EscapeCshString(val,escaped);
1047
1048 if(( lmfiles_len = strlen(escaped)) > LMSPLIT_SIZE) {
1049
1050 char buffer[ LMSPLIT_SIZE + 1];
1051
1052 /**
1053 ** Break up the _LMFILES_ variable...
1054 **/
1055 while( lmfiles_len > LMSPLIT_SIZE) {
1056
1057 strncpy( buffer, ( escaped + count*LMSPLIT_SIZE ),
1058 LMSPLIT_SIZE);
1059 buffer[ LMSPLIT_SIZE] = '\0';
1060
1061 fprintf( stdout, "setenv %s%03d %s %s", var, count, buffer,
1062 shell_cmd_separator);
1063
1064 lmfiles_len -= LMSPLIT_SIZE;
1065 count++;
1066 }
1067
1068 if( lmfiles_len) {
1069 fprintf( stdout, "setenv %s%03d %s %s", var, count,
1070 (escaped + count*LMSPLIT_SIZE), shell_cmd_separator);
1071 count++;
1072 }
1073
1074 /**
1075 ** Unset _LMFILES_ as indicator to use the multi-variable
1076 ** _LMFILES_
1077 **/
1078 fprintf(stdout, "unsetenv %s %s", var, shell_cmd_separator);
1079
1080 } else { /** if ( lmfiles_len = strlen(val)) > LMSPLIT_SIZE) **/
1081
1082 fprintf(stdout, "setenv %s %s %s", var, escaped, shell_cmd_separator);
1083 }
1084
1085 /**
1086 ** Unset the extra _LMFILES_%03d variables that may be set
1087 **/
1088 do {
1089 if (cptr) null_free((void *) &cptr);
1090 sprintf( formatted, "_LMFILES_%03d", count++);
1091 cptr = EMGetEnv( interp, formatted);
1092 if(cptr && *cptr) {
1093 fprintf(stdout, "unsetenv %s %s", formatted,
1094 shell_cmd_separator);
1095 }
1096 } while( cptr && *cptr);
1097
1098 null_free((void *) &cptr);
1099 null_free((void *) &escaped);
1100
1101 } else { /** if( var == "_LMFILES_") **/
1102
1103 #endif /* not LMSPLIT_SIZE */
1104
1105 char* escaped = stringer(NULL,strlen(val)*2+1,NULL);
1106 EscapeCshString(val,escaped);
1107 fprintf(stdout, "setenv %s %s %s", var, escaped,
1108 shell_cmd_separator);
1109 null_free((void *) &escaped);
1110 #ifdef LMSPLIT_SIZE
1111 }
1112 #endif /* not LMSPLIT_SIZE */
1113
1114 /**
1115 ** SH
1116 **/
1117 } else if( !strcmp((char*) shell_derelict, "sh")) {
1118
1119 char* escaped = (char*)module_malloc(strlen(val)*2+1);
1120 EscapeShString(val,escaped);
1121
1122 fprintf( stdout, "%s=%s %sexport %s%s", var, escaped, shell_cmd_separator,
1123 var, shell_cmd_separator);
1124 free(escaped);
1125
1126 /**
1127 ** EMACS
1128 **/
1129 } else if( !strcmp((char*) shell_derelict, "emacs")) {
1130 fprintf( stdout, "(setenv \"%s\" \'%s\')\n", var, val);
1131
1132 /**
1133 ** PERL
1134 **/
1135 } else if( !strcmp((char*) shell_derelict, "perl")) {
1136 char* escaped = stringer(NULL,strlen(val)*2+1,NULL);
1137 EscapePerlString(val,escaped);
1138 fprintf(stdout, "$ENV{'%s'} = '%s'%s", var, escaped,
1139 shell_cmd_separator);
1140 null_free((void *) &escaped);
1141
1142 /**
1143 ** PYTHON
1144 **/
1145 } else if( !strcmp((char*) shell_derelict, "python")) {
1146 fprintf( stdout, "os.environ['%s'] = '%s'\n", var, val);
1147
1148 /**
1149 ** RUBY
1150 **/
1151 } else if( !strcmp((char*) shell_derelict, "ruby")) {
1152 fprintf( stdout, "ENV['%s'] = '%s'\n", var, val);
1153
1154 /**
1155 ** CMAKE
1156 **/
1157 } else if( !strcmp((char*) shell_derelict, "cmake")) {
1158 char* escaped = stringer(NULL, strlen(val)*2+1,NULL);
1159 EscapeCmakeString(val,escaped);
1160 fprintf(stdout, "set(ENV{%s} \"%s\")%s", var, escaped,
1161 shell_cmd_separator);
1162 null_free((void *) &escaped);
1163
1164 /**
1165 ** SCM
1166 **/
1167 } else if ( !strcmp((char*) shell_derelict, "scm")) {
1168 fprintf( stdout, "(putenv \"%s=%s\")\n", var, val);
1169
1170 /**
1171 ** MEL (Maya Extension Language)
1172 **/
1173 } else if ( !strcmp((char*) shell_derelict, "mel")) {
1174 fprintf( stdout, "putenv \"%s\" \"%s\";", var, val);
1175
1176 /**
1177 ** Unknown shell type - print an error message and
1178 ** return on error
1179 **/
1180 } else {
1181 if( OK != ErrorLogger( ERR_DERELICT, LOC, shell_derelict, NULL))
1182 return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
1183 }
1184
1185 /**
1186 ** Return and acknowldge success
1187 **/
1188 g_output = 1;
1189 return( TCL_OK);
1190
1191 } /** End of 'output_set_variable' **/
1192
1193 /*++++
1194 ** ** Function-Header ***************************************************** **
1195 ** **
1196 ** Function: output_unset_variable **
1197 ** **
1198 ** Description: Outputs the command required to unset a shell **
1199 ** variable according to the current shell **
1200 ** **
1201 ** First Edition: 1991/10/23 **
1202 ** **
1203 ** Parameters: const char *var Name of the variable to be **
1204 ** unset **
1205 ** **
1206 ** Result: int TCL_OK Finished successful **
1207 ** TCL_ERROR Unknown shell type **
1208 ** **
1209 ** Attached Globals: shell_derelict **
1210 ** **
1211 ** ************************************************************************ **
1212 ++++*/
1213
output_unset_variable(const char * var)1214 static int output_unset_variable( const char* var)
1215 {
1216 chop( var);
1217
1218 assert(shell_derelict != NULL);
1219 #if WITH_DEBUGGING_UTIL_2
1220 ErrorLogger( NO_ERR_START, LOC, _proc_output_unset_variable, NULL);
1221 #endif
1222
1223 /**
1224 ** Display the 'unsetenv' command according to the current invoking shell.
1225 **/
1226 if( !strcmp( shell_derelict, "csh")) {
1227 fprintf( stdout, "unsetenv %s%s", var, shell_cmd_separator);
1228 } else if( !strcmp( shell_derelict, "sh")) {
1229 fprintf( stdout, "unset %s%s", var, shell_cmd_separator);
1230 } else if( !strcmp( shell_derelict, "emacs")) {
1231 fprintf( stdout, "(setenv \"%s\" nil)\n", var);
1232 } else if( !strcmp( shell_derelict, "perl")) {
1233 fprintf( stdout, "delete $ENV{'%s'}%s", var, shell_cmd_separator);
1234 } else if( !strcmp( shell_derelict, "cmake")) {
1235 fprintf( stdout, "unset(ENV{%s})%s", var, shell_cmd_separator);
1236 } else if( !strcmp( shell_derelict, "python")) {
1237 fprintf( stdout, "os.environ['%s'] = ''\ndel os.environ['%s']\n",var,var);
1238 } else if( !strcmp( shell_derelict, "ruby")) {
1239 fprintf( stdout, "ENV['%s'] = nil\n",var);
1240 } else if( !strcmp( shell_derelict, "scm")) {
1241 fprintf( stdout, "(putenv \"%s\")\n", var);
1242 } else if( !strcmp( shell_derelict, "mel")) {
1243 fprintf( stdout, "putenv \"%s\" \"\";", var);
1244 } else {
1245 if( OK != ErrorLogger( ERR_DERELICT, LOC, shell_derelict, NULL))
1246 return( TCL_ERROR); /** -------- EXIT (FAILURE) -------> **/
1247 }
1248
1249 /**
1250 ** Return and acknowldge success
1251 **/
1252 g_output = 1;
1253 return( TCL_OK);
1254
1255 } /** End of 'output_unset_variable' **/
1256
1257 /*++++
1258 ** ** Function-Header ***************************************************** **
1259 ** **
1260 ** Function: output_function **
1261 ** **
1262 ** Description: Actually turns the Modules set-alias information **
1263 ** into a string that a shell can source. Previously, **
1264 ** this routine just output the alias information to be **
1265 ** eval'd by the shell. **
1266 ** **
1267 ** First Edition: 1991/10/23 **
1268 ** **
1269 ** Parameters: const char *var Name of the alias to be set **
1270 ** const char *val Value to be assigned **
1271 ** **
1272 ** Result: - **
1273 ** **
1274 ** Attached Globals: aliasfile, The output file for alias commands. **
1275 ** see 'Output_Modulefile_Aliases' **
1276 ** alias_separator **
1277 ** **
1278 ** ************************************************************************ **
1279 ++++*/
1280
output_function(const char * var,const char * val)1281 static void output_function( const char *var,
1282 const char *val)
1283 {
1284 const char *cptr = val;
1285 int nobackslash = 1;
1286
1287 #if WITH_DEBUGGING_UTIL_2
1288 ErrorLogger(NO_ERR_START, LOC, _proc_output_function, NULL);
1289 #endif
1290
1291 /**
1292 ** This opens a function ...
1293 **/
1294 fprintf(aliasfile, "%s() { ", var);
1295
1296 /**
1297 ** ... now print the value. Print it as a single line and remove any
1298 ** backslashes, and substitute a safe $*
1299 **/
1300 while (*cptr) {
1301
1302 if (*cptr == '\\') {
1303 if (!nobackslash)
1304 putc(*cptr, aliasfile);
1305 else
1306 nobackslash = 0;
1307 cptr++;
1308 continue;
1309 } else if (*cptr == '$' && (cptr + 1) && (*(cptr + 1) == '*')) {
1310 /* found $* */
1311 fputs("${1+\"$@\"}", aliasfile);
1312 cptr++;
1313 cptr++;
1314 continue;
1315 } else
1316 nobackslash = 1;
1317
1318 putc(*cptr++, aliasfile);
1319
1320 } /** while **/
1321
1322 /**
1323 ** Finally close the function
1324 **/
1325 fprintf(aliasfile, "%c}%c", alias_separator, alias_separator);
1326
1327 } /** End of 'output_function' **/
1328
1329 /*++++
1330 ** ** Function-Header ***************************************************** **
1331 ** **
1332 ** Function: output_set_alias **
1333 ** **
1334 ** Description: Flush the commands required to set shell aliases de- **
1335 ** pending on the current invoking shell **
1336 ** **
1337 ** First Edition: 1991/10/23 **
1338 ** **
1339 ** Parameters: const char *alias Name of the alias **
1340 ** const char *val Value to be assigned **
1341 ** **
1342 ** Result: int TCL_OK Operation successful **
1343 ** **
1344 ** Attached Globals: aliasfile, The alias command is written out to **
1345 ** alias_separator Defined the command separator **
1346 ** shell_derelict to determine the shell family **
1347 ** shell_name to determine the real shell type **
1348 ** **
1349 ** ************************************************************************ **
1350 ++++*/
1351
output_set_alias(const char * alias,const char * val)1352 static int output_set_alias( const char *alias,
1353 const char *val)
1354 {
1355 int nobackslash = 1; /** Controls whether backslashes are **/
1356 /** to be print **/
1357 const char *cptr = val; /** Scan the value char by char **/
1358
1359 assert(shell_derelict != NULL);
1360 #if WITH_DEBUGGING_UTIL_2
1361 ErrorLogger( NO_ERR_START, LOC, _proc_output_set_alias, NULL);
1362 #endif
1363
1364 /**
1365 ** Check for the shell family
1366 ** CSHs need to switch $* to \!* and $n to \!\!:n unless the $ has a
1367 ** backslash before it
1368 **/
1369 if( !strcmp( shell_derelict, "csh")) {
1370
1371 /**
1372 ** On CSHs the command is 'alias <name> <value>'. Print the beginning
1373 ** of the command and then print the value char by char.
1374 **/
1375 fprintf( aliasfile, "alias %s '", alias);
1376
1377 while( *cptr) {
1378
1379 /**
1380 ** Convert $n to \!\!:n
1381 **/
1382 if( *cptr == '$' && nobackslash) {
1383 cptr++;
1384 if( *cptr == '*')
1385 fprintf( aliasfile, "\\!");
1386 else
1387 fprintf( aliasfile, "\\!\\!:");
1388 }
1389
1390 /**
1391 ** Recognize backslashes
1392 **/
1393 if( *cptr == '\\') {
1394 if( !nobackslash)
1395 putc( *cptr, aliasfile);
1396 else
1397 nobackslash = 0;
1398 cptr++;
1399 continue;
1400 } else
1401 nobackslash = 1;
1402
1403 /**
1404 ** print the read character
1405 **/
1406 putc( *cptr++, aliasfile);
1407
1408 } /** while **/
1409
1410 /**
1411 ** Now close up the command using the alias command terminator as
1412 ** defined in the global variable
1413 **/
1414 fprintf( aliasfile, "'%c", alias_separator);
1415
1416 /**
1417 ** Bourne shell family: The alias has to be translated into a
1418 ** function using the function call 'output_function'
1419 **/
1420 } else if( !strcmp(shell_derelict, "sh")) {
1421 /**
1422 ** Shells supporting extended bourne shell syntax ....
1423 **/
1424 if( (!strcmp( shell_name, "sh") && bourne_alias)
1425 || (!strcmp( shell_name, "bash") && is_interactive())
1426 || !strcmp( shell_name, "zsh" )
1427 || !strcmp( shell_name, "ksh")) {
1428 /**
1429 ** in this case we only have to write a function if the alias
1430 ** takes arguments. This is the case if the value has '$'
1431 ** somewhere in it without a '\' in front.
1432 **/
1433 while( *cptr) {
1434 if( *cptr == '\\') {
1435 if( nobackslash) {
1436 nobackslash = 0;
1437 }
1438 } else {
1439 if( *cptr == '$') {
1440 if( nobackslash) {
1441 output_function( alias, val);
1442 return TCL_OK;
1443 }
1444 }
1445 nobackslash = 1;
1446 }
1447 cptr++;
1448 }
1449
1450 /**
1451 ** So, we can just output an alias with '\$' translated to '$'...
1452 **/
1453 fprintf( aliasfile, "alias %s='", alias);
1454
1455 nobackslash = 1;
1456 cptr = val;
1457
1458 while( *cptr) {
1459 if( *cptr == '\\') {
1460 if( nobackslash) {
1461 nobackslash = 0;
1462 cptr++;
1463 continue;
1464 }
1465 }
1466 nobackslash = 1;
1467
1468 putc(*cptr++, aliasfile);
1469
1470 } /** while **/
1471
1472 fprintf( aliasfile, "'%c", alias_separator);
1473
1474 } else if( ((!strcmp( shell_name, "sh")) && bourne_funcs)
1475 || (!strcmp( shell_name, "bash") && !is_interactive())) {
1476 /**
1477 ** The bourne shell itself
1478 ** need to write a function unless this sh doesn't support
1479 ** functions (then just punt)
1480 **/
1481 output_function(alias, val);
1482 }
1483 /** ??? Unknown derelict ??? **/
1484
1485 } /** if( sh ) **/
1486
1487 return( TCL_OK);
1488
1489 } /** End of 'output_set_alias' **/
1490
1491 /*++++
1492 ** ** Function-Header ***************************************************** **
1493 ** **
1494 ** Function: output_unset_alias **
1495 ** **
1496 ** Description: Flush the commands required to reset shell aliases **
1497 ** depending on the current invoking shell **
1498 ** **
1499 ** First Edition: 1991/10/23 **
1500 ** **
1501 ** Parameters: const char *alias Name of the alias **
1502 ** const char *val Value which has been **
1503 ** assigned **
1504 ** **
1505 ** Result: int TCL_OK Operation successful **
1506 ** **
1507 ** Attached Globals: aliasfile, The alias command is writte out to **
1508 ** alias_separator Defined the command separator **
1509 ** shell_derelict to determine the shell family **
1510 ** shell_name to determine the real shell type **
1511 ** **
1512 ** ************************************************************************ **
1513 ++++*/
1514
output_unset_alias(const char * alias,const char * val)1515 static int output_unset_alias( const char *alias,
1516 const char *val)
1517 {
1518 int nobackslash = 1; /** Controls wether backslashes are **/
1519 /** to be print **/
1520 const char *cptr = val; /** Need to read the value char by char **/
1521
1522 assert(shell_derelict != NULL);
1523 #if WITH_DEBUGGING_UTIL_2
1524 ErrorLogger( NO_ERR_START, LOC, _proc_output_unset_alias, NULL);
1525 #endif
1526
1527 /**
1528 ** Check for the shell family at first
1529 ** Ahh! CSHs ... ;-)
1530 **/
1531 if( !strcmp( shell_derelict, "csh")) {
1532 fprintf( aliasfile, "unalias %s%c", alias, alias_separator);
1533
1534 /**
1535 ** Hmmm ... bourne shell types ;-(
1536 ** Need to unset a function in case of sh or if the alias took parameters
1537 **/
1538 } else if( !strcmp( shell_derelict, "sh")) {
1539
1540 if( (!strcmp( shell_name, "sh") && bourne_alias)
1541 || (!strcmp( shell_name, "bash") && is_interactive())
1542 || !strcmp( shell_name, "zsh" )
1543 || !strcmp( shell_name, "ksh")) {
1544 /**
1545 ** If we have what the old value should have been, then look to
1546 ** see if it was a function or an alias because bash spits out an
1547 ** error if you try to unalias a non-existent alias.
1548 **/
1549 if(val) {
1550
1551 /**
1552 ** Was it a function?
1553 ** Yes, if it has arguments...
1554 **/
1555 while( *cptr) {
1556 if( *cptr == '\\') {
1557 if( nobackslash) {
1558 nobackslash = 0;
1559 }
1560 } else {
1561 if(*cptr == '$') {
1562 if( nobackslash) {
1563 fprintf(aliasfile, "unset -f %s%c", alias,
1564 alias_separator);
1565 return TCL_OK;
1566 }
1567 }
1568 nobackslash = 1;
1569 }
1570 cptr++;
1571 }
1572
1573 /**
1574 ** Well, it wasn't a function, so we'll put out an unalias...
1575 **/
1576 fprintf( aliasfile, "unalias %s%c", alias, alias_separator);
1577
1578 } else { /** No value known (any more?) **/
1579
1580 /** We want to make sure to get remove the alias/function,
1581 ** but avoid generating commands which might throw an error!
1582 ** How exactly this can be done depends on the used shell
1583 **/
1584 if( !strcmp( shell_name, "zsh")) {
1585 /** zsh has "-m" for pattern matching, which won't complain
1586 ** about non-existing functions/aliases
1587 **/
1588 fprintf( aliasfile, "unset -fm %s%c", alias, alias_separator);
1589 fprintf( aliasfile, "unhash -am %s%c", alias, alias_separator);
1590 } else if( !strcmp( shell_name, "ksh")) {
1591 /** ksh doesn't complain about unsetting non-existing
1592 ** functions/aliases, so we can try both
1593 **/
1594 fprintf( aliasfile, "unset -f %s%c", alias, alias_separator);
1595 fprintf( aliasfile, "unalias %s%c", alias, alias_separator);
1596 } else {
1597 /** bash will complain about unsetting a non-existing alias,
1598 ** so we just try to unset the function.
1599 ** "sh" can be any Bourne-compatible shell, and will on most
1600 ** systems be bash in POSIX-mode, so let's handle it the same
1601 **/
1602 fprintf( aliasfile, "unset -f %s%c", alias, alias_separator);
1603 }
1604
1605 }
1606
1607 } else if( ((!strcmp( shell_name, "sh")) && bourne_funcs)
1608 || (!strcmp( shell_name, "bash") && !is_interactive())) {
1609 fprintf(aliasfile, "unset -f %s%c", alias, alias_separator);
1610
1611 } /** if (shell supports aliases) **/
1612
1613 /** ??? Unknown derelict ??? **/
1614
1615 } /** if( sh-family) **/
1616
1617 return( TCL_OK);
1618
1619 } /** End of 'output_unset_alias' **/
1620
1621 /*++++
1622 ** ** Function-Header ***************************************************** **
1623 ** **
1624 ** Function: getLMFILES **
1625 ** **
1626 ** Description: Read in the _LMFILES_ environment variable. This one **
1627 ** may be split into several variables cause by limited **
1628 ** variable space of some shells (esp. the SUN csh) **
1629 ** **
1630 ** First Edition: 1991/10/23 **
1631 ** **
1632 ** Parameters: Tcl_Interp *interp Attached Tcl interpreter **
1633 ** **
1634 ** Result: char* Value of the environment varibale _LMFILES_ **
1635 ** **
1636 ** Attached Globals: **
1637 ** **
1638 ** ************************************************************************ **
1639 ++++*/
1640
getLMFILES(Tcl_Interp * interp)1641 char *getLMFILES( Tcl_Interp *interp)
1642 {
1643 static char *lmfiles = NULL; /** Buffer pointer for the value **/
1644
1645 #if WITH_DEBUGGING_UTIL_2
1646 ErrorLogger( NO_ERR_START, LOC, _proc_getLMFILES, NULL);
1647 #endif
1648
1649 /**
1650 ** Try to read the variable _LMFILES_. If the according buffer pointer
1651 ** contains a value, disallocate it before.
1652 **/
1653 if( lmfiles)
1654 null_free((void *) &lmfiles);
1655
1656 lmfiles = EMGetEnv( interp, "_LMFILES_");
1657
1658 /**
1659 ** Now the pointer is NULL in case of the variable has not been defined.
1660 ** In this case try to read in the splitted variable from _LMFILES_xxx
1661 **/
1662 if( !lmfiles || !*lmfiles) {
1663
1664 char buffer[ MOD_BUFSIZE]; /** Used to set up the split variab- **/
1665 /** les name **/
1666 int count = 0; /** Split part count **/
1667 int lmsize = 0; /** Total size of _LMFILES_ content **/
1668 int old_lmsize; /** Size save buffer **/
1669 int cptr_len; /** Size of the current split part **/
1670 char *cptr; /** Split part read pointer **/
1671
1672 /**
1673 ** Set up the split part environment variable name and try to read it
1674 ** in
1675 **/
1676 sprintf( buffer, "_LMFILES_%03d", count++);
1677 cptr = EMGetEnv( interp, buffer);
1678
1679 while(cptr && *cptr) { /** Something available **/
1680
1681 /**
1682 ** Count up the variables length
1683 **/
1684 cptr_len = strlen( cptr);
1685 old_lmsize = lmsize;
1686 lmsize += cptr_len;
1687
1688 /**
1689 ** Reallocate the value's buffer and copy the current split
1690 ** part at its end
1691 **/
1692 if(!(lmfiles =
1693 (char*) module_realloc( lmfiles, lmsize * sizeof(char) + 1))) {
1694 if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
1695 return( NULL); /** ---- EXIT (FAILURE) ---> **/
1696 }
1697
1698 strncpy( lmfiles + old_lmsize, cptr, cptr_len);
1699 *(lmfiles + old_lmsize + cptr_len) = '\0';
1700
1701 /**
1702 ** Read the next split part variable
1703 **/
1704 sprintf( buffer, "_LMFILES_%03d", count++);
1705 cptr = EMGetEnv( interp,buffer);
1706 }
1707
1708 } else { /** if( lmfiles) **/
1709
1710 /**
1711 ** If the environvariable _LMFILES_ has been set, copy the contents
1712 ** of the returned buffer into a free allocated one in order to
1713 ** avoid side effects.
1714 **/
1715 char *tmp = stringer(NULL,0, lmfiles, NULL);
1716
1717 if( !tmp)
1718 if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
1719 return( NULL); /** -------- EXIT (FAILURE) -------> **/
1720
1721 /**
1722 ** Set up lmfiles pointing to the new buffer in order to be able to
1723 ** disallocate when invoked next time.
1724 **/
1725 lmfiles = tmp;
1726
1727 } /** if( lmfiles) **/
1728
1729 /**
1730 ** Return the received value to the caller
1731 **/
1732 return( lmfiles);
1733
1734 } /** end of 'getLMFILES' **/
1735
1736 /*++++
1737 ** ** Function-Header ***************************************************** **
1738 ** **
1739 ** Function: IsLoaded **
1740 ** **
1741 ** Description: Check whether the passed modulefile is currently **
1742 ** loaded **
1743 ** **
1744 ** First Edition: 1991/10/23 **
1745 ** **
1746 ** Parameters: Tcl_Interp *interp According Tcl interp.**
1747 ** char *modulename Name of the module to**
1748 ** be searched for **
1749 ** char **realname Buffer for the name **
1750 ** and version of the **
1751 ** module that has mat- **
1752 ** ched the query **
1753 ** char *filename Buffer to store the **
1754 ** whole filename of a **
1755 ** found loaded module **
1756 ** **
1757 ** Result: int 0 Requested module not loaded **
1758 ** 1 module is loaded **
1759 ** **
1760 ** realname points to the name of the module that**
1761 ** has matched the query. If this poin- **
1762 ** differs form 'modulename' after this **
1763 ** function has finished, the buffer for**
1764 ** to store the module name in has been **
1765 ** allocated here. **
1766 ** if (char **) NULL is passed, no buf- **
1767 ** fer will be allocated **
1768 ** ??? Is this freed correctly by the caller ???**
1769 ** **
1770 ** filename will be filled with the full module **
1771 ** file path of the module that has **
1772 ** matched the query **
1773 ** **
1774 ** Attached Globals: **
1775 ** **
1776 ** ************************************************************************ **
1777 ++++*/
1778
1779 /**
1780 ** Check all possibilities of module-versions
1781 **/
1782
IsLoaded(Tcl_Interp * interp,char * modulename,char ** realname,char * filename)1783 int IsLoaded( Tcl_Interp *interp,
1784 char *modulename,
1785 char **realname,
1786 char *filename )
1787 {
1788 return( __IsLoaded( interp, modulename, realname, filename, 0));
1789 }
1790
1791 /**
1792 ** Check only an exact match of the passed module and version
1793 **/
IsLoaded_ExactMatch(Tcl_Interp * interp,char * modulename,char ** realname,char * filename)1794 int IsLoaded_ExactMatch( Tcl_Interp *interp,
1795 char *modulename,
1796 char **realname,
1797 char *filename )
1798 {
1799 return( __IsLoaded( interp, modulename, realname, filename, 1));
1800 }
1801
1802 /**
1803 ** The subroutine __IsLoaded finally checks for the requested module being
1804 ** loaded or not.
1805 **/
__IsLoaded(Tcl_Interp * interp,char * modulename,char ** realname,char * filename,int exact)1806 static int __IsLoaded( Tcl_Interp *interp,
1807 char *modulename,
1808 char **realname,
1809 char *filename,
1810 int exact)
1811 {
1812 char *l_modules = NULL; /** Internal module list buffer **/
1813 char *l_modulefiles = NULL; /** Internal module file list buffer **/
1814 char *loaded = NULL; /** Buffer for the module **/
1815 char *basename = NULL; /** Pointer to module basename **/
1816 char *loadedmodule_path = NULL; /** Pointer to one loaded module out **/
1817 /** of the loaded modules list **/
1818 int count = 0;
1819
1820 /**
1821 ** Get a list of loaded modules (environment variable 'LOADEDMODULES')
1822 ** and the list of loaded module-files (env. var. __LMFILES__)
1823 **/
1824 char *loaded_modules = EMGetEnv( interp, "LOADEDMODULES");
1825 char *loaded_modulefiles = getLMFILES( interp);
1826
1827 #if WITH_DEBUGGING_UTIL_2
1828 ErrorLogger( NO_ERR_START, LOC, _proc___IsLoaded, NULL);
1829 #endif
1830
1831 /**
1832 ** If no module is currently loaded ... the requested module is surely
1833 ** not loaded, too ;-)
1834 **/
1835 if( !loaded_modules || !*loaded_modules) {
1836 goto unwind0;
1837 }
1838
1839 /**
1840 ** Copy the list of currently loaded modules into a new allocated array
1841 ** for further handling. If this fails it will be assumed, that the
1842 ** module is *NOT* loaded.
1843 **/
1844 if((char *) NULL == (l_modules = stringer(NULL,0,loaded_modules,NULL)))
1845 if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
1846 goto unwind0;
1847
1848 /**
1849 ** Copy the list of currently loaded modulefiles into a new allocated
1850 ** array for further handling. If this failes it will be assumed, that
1851 ** the module is *NOT* loaded.
1852 **/
1853 if(loaded_modulefiles)
1854 if((char *) NULL == (l_modulefiles = stringer(NULL,0,
1855 loaded_modulefiles,NULL)))
1856 if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
1857 goto unwind1;
1858
1859 /**
1860 ** Assume the modulename given was an exact match so there is no
1861 ** difference to return -- this will change in the case it wasn't an
1862 ** exact match below
1863 **/
1864 if( realname)
1865 *realname = modulename;
1866
1867 if( *l_modules) {
1868
1869 /**
1870 ** Get each single module which is loaded by splitting up at colons
1871 ** The variable LOADEDMODULES contains a list of modulefile like the
1872 ** following:
1873 ** gnu/2.0:openwin/3.0
1874 **/
1875 loadedmodule_path = xstrtok( l_modules, ":");
1876 while( loadedmodule_path) {
1877
1878 if((char *) NULL == (loaded = stringer(NULL,0,
1879 loadedmodule_path,NULL)))
1880 if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
1881 goto unwind2;
1882
1883 /**
1884 ** Get a modulefile without a version and check if this is the
1885 ** requested one.
1886 **/
1887 if( !strcmp( loaded, modulename)) { /** FOUND **/
1888
1889 null_free ((void *) &loaded);
1890 break; /** leave the while loop **/
1891
1892 } else if( !exact) { /** NOT FOUND **/
1893
1894 /**
1895 ** Try to more and more simplify the modulename by removing
1896 ** all detail (version) information
1897 **/
1898 basename = get_module_basename( loaded);
1899 while( basename && strcmp( basename, modulename)) {
1900 basename = get_module_basename( basename);
1901 }
1902
1903 /**
1904 ** Something left after splitting again? If yes the requested
1905 ** module is found!
1906 ** Since the name given was a basename, return the fully
1907 ** loaded path
1908 **/
1909 if( basename) {
1910 null_free ((void *) &loaded);
1911 if( realname)
1912 if((char *) NULL == (*realname = stringer(NULL,0,
1913 loadedmodule_path,NULL)))
1914 if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
1915 goto unwind2;
1916
1917 break; /** leave the while loop **/
1918
1919 } /** if( basename) **/
1920 } /** if not found with single basename **/
1921
1922 /**
1923 ** Get the next entry from the loaded modules list
1924 **/
1925 loadedmodule_path = xstrtok( NULL, ":");
1926 count++;
1927
1928 null_free ((void *) &loaded); /** Free what has been alloc. **/
1929
1930 } /** while **/
1931 } /** if( *l_modules) **/
1932
1933 /**
1934 ** If we found something locate it's associated modulefile
1935 **/
1936 if( loadedmodule_path) {
1937 if( filename && l_modulefiles && *l_modulefiles) {
1938
1939 /**
1940 ** The position of the loaded module within the list of loaded
1941 ** modules has been counted in 'count'. The position of the
1942 ** associated modulefile should be the same. So tokenize the
1943 ** list of modulefiles by the colon until the wanted position
1944 ** is reached.
1945 **/
1946 char* modulefile_path = xstrtok(l_modulefiles, ":");
1947
1948 while( count) {
1949 if( !( modulefile_path = xstrtok( NULL, ":"))) {
1950
1951 /**
1952 ** Oops! Fewer entries in the list of loaded modulefiles
1953 ** than in the list of loaded modules. This will
1954 ** generally suggest that _LMFILES_ has become corrupted,
1955 ** but it may just mean we're working intermittantly with
1956 ** an old version. So, I'll just not touch filename which
1957 ** means the search will continue using the old method of
1958 ** looking through MODULEPATH.
1959 */
1960 goto success0;
1961 }
1962 count--;
1963
1964 } /** while **/
1965
1966 /**
1967 ** Copy the result into the buffer passed from the caller
1968 **/
1969 strcpy( filename, modulefile_path);
1970 }
1971
1972 /**
1973 ** FOUND.
1974 ** free up everything which has been allocated and return on success
1975 **/
1976 goto success0;
1977 }
1978
1979 /**
1980 ** NOT FOUND. Free up everything which has been alloc'd and return on
1981 ** failure
1982 **/
1983
1984 unwind2:
1985 if( l_modulefiles)
1986 null_free((void *) &l_modulefiles);
1987 unwind1:
1988 null_free((void *) &l_modules);
1989 unwind0:
1990 null_free((void *)&loaded_modules);
1991 return( 0); /** -------- EXIT (FAILURE) -------> **/
1992
1993 success0:
1994 if( l_modulefiles)
1995 null_free((void *) &l_modulefiles);
1996 null_free((void *) &l_modules);
1997 return( 1); /** -------- EXIT (SUCCESS) -------> **/
1998
1999 } /** End of '__IsLoaded' **/
2000
2001 /*++++
2002 ** ** Function-Header ***************************************************** **
2003 ** **
2004 ** Function: chk_marked_entry, set_marked_entry **
2005 ** **
2006 ** Description: When switching, the variables are marked with a mar- **
2007 ** ker that is tested to see if the variable was changed**
2008 ** in the second modulefile. If it was not, then the **
2009 ** variable is unset. **
2010 ** **
2011 ** First Edition: 1992/10/25 **
2012 ** **
2013 ** Parameters: Tcl_HashTable *table Attached hash table **
2014 ** char *var According variable name **
2015 ** int val Value to be set. **
2016 ** **
2017 ** Result: int 0 Mark not set (or the value of the **
2018 ** mark was 0 ;-) **
2019 ** else Value of the mark that has been set **
2020 ** with set_marked_entry. **
2021 ** Attached Globals: - **
2022 ** **
2023 ** ************************************************************************ **
2024 ++++*/
2025
chk_marked_entry(Tcl_HashTable * table,char * var)2026 intptr_t chk_marked_entry( Tcl_HashTable *table,
2027 char *var)
2028 {
2029 Tcl_HashEntry *hentry;
2030
2031 #if WITH_DEBUGGING_UTIL_2
2032 ErrorLogger( NO_ERR_START, LOC, _proc_chk_marked_entry, NULL);
2033 #endif
2034
2035 if( hentry = Tcl_FindHashEntry( table, var))
2036 return((intptr_t) Tcl_GetHashValue( hentry));
2037 else
2038 return 0;
2039 }
2040
set_marked_entry(Tcl_HashTable * table,char * var,intptr_t val)2041 void set_marked_entry( Tcl_HashTable *table,
2042 char *var,
2043 intptr_t val)
2044 {
2045 Tcl_HashEntry *hentry;
2046 int new;
2047
2048 #if WITH_DEBUGGING_UTIL_2
2049 ErrorLogger( NO_ERR_START, LOC, _proc_set_marked_entry, NULL);
2050 #endif
2051
2052 if( (hentry = Tcl_CreateHashEntry( table, var, &new))) {
2053 if( val)
2054 Tcl_SetHashValue( hentry, val);
2055 }
2056
2057 /** ??? Shouldn't there be an error return in case of hash creation
2058 failing ??? **/
2059 }
2060
2061 /*++++
2062 ** ** Function-Header ***************************************************** **
2063 ** **
2064 ** Function: get_module_basename **
2065 ** **
2066 ** Description: Get the name of a module without its version. **
2067 ** This function modifies the string passed in. **
2068 ** **
2069 ** First Edition: 1991/10/23 **
2070 ** **
2071 ** Parameters: char *modulename Full module name **
2072 ** **
2073 ** Result: char* Module name without version **
2074 ** **
2075 ** Attached Globals: **
2076 ** **
2077 ** ************************************************************************ **
2078 ++++*/
2079
get_module_basename(char * modulename)2080 static char *get_module_basename( char *modulename)
2081 {
2082 char *version; /** Used to locate the version sep. **/
2083
2084 #if WITH_DEBUGGING_UTIL_2
2085 ErrorLogger( NO_ERR_START, LOC, _proc_get_module_basename, NULL);
2086 #endif
2087
2088 /**
2089 ** Use strrchr to locate the very last version string on the module
2090 ** name.
2091 **/
2092 if((version = strrchr( modulename, '/'))) {
2093 *version = '\0';
2094 } else {
2095 modulename = NULL;
2096 }
2097
2098 /**
2099 ** Return the *COPIED* string
2100 **/
2101 return( modulename);
2102
2103 } /** End of 'get_module_basename' **/
2104
2105 /*++++
2106 ** ** Function-Header ***************************************************** **
2107 ** **
2108 ** Function: Update_LoadedList **
2109 ** **
2110 ** Description: Add or remove the passed modulename and filename to/ **
2111 ** from LOADEDMODULES and _LMFILES_ **
2112 ** **
2113 ** First Edition: 1991/10/23 **
2114 ** **
2115 ** Parameters: Tcl_Interp *interp Attached Tcl Interp. **
2116 ** char *modulename Name of the module **
2117 ** char *filename Full path name of the**
2118 ** related modulefile **
2119 ** **
2120 ** Result: int 1 Successful operation **
2121 ** **
2122 ** Attached Globals: g_flags Controls whether the modulename **
2123 ** should be added (M_XXXX) or removed **
2124 ** (M_REMOVE) from the list of loaded **
2125 ** modules **
2126 ** **
2127 ** ************************************************************************ **
2128 ++++*/
2129
Update_LoadedList(Tcl_Interp * interp,char * modulename,char * filename)2130 int Update_LoadedList( Tcl_Interp *interp,
2131 char *modulename,
2132 char *filename)
2133 {
2134 char *argv[4];
2135 char *basename;
2136 char *module;
2137
2138 #if WITH_DEBUGGING_UTIL_2
2139 ErrorLogger( NO_ERR_START, LOC, _proc_Update_LoadedList, NULL);
2140 #endif
2141
2142 /**
2143 ** Apply changes to LOADEDMODULES first
2144 **/
2145 argv[1] = "LOADEDMODULES";
2146 argv[2] = modulename;
2147 argv[3] = NULL;
2148
2149 if(g_flags & M_REMOVE) {
2150 argv[0] = "remove-path";
2151 cmdRemovePath( 0, interp, 3, (CONST84 char **) argv);
2152 } else {
2153 argv[0] = "append-path";
2154 cmdSetPath( 0, interp, 3, (CONST84 char **) argv);
2155 }
2156
2157 /**
2158 ** Apply changes to _LMFILES_ now
2159 **/
2160 argv[1] = "_LMFILES_";
2161 argv[2] = filename;
2162 argv[3] = NULL;
2163
2164 if(g_flags & M_REMOVE) {
2165 argv[0] = "remove-path";
2166 cmdRemovePath( 0, interp, 3, (CONST84 char **) argv);
2167 } else {
2168 argv[0] = "append-path";
2169 cmdSetPath( 0, interp, 3, (CONST84 char **) argv);
2170 }
2171
2172 /**
2173 ** A module with just the basename might have been added and now we're
2174 ** removing one of its versions. We'll want to look for the basename in
2175 ** the path too.
2176 **/
2177 if( g_flags & M_REMOVE) {
2178 module = stringer(NULL,0, modulename, NULL);
2179 basename = module;
2180 if( basename = get_module_basename( basename)) {
2181 argv[2] = basename;
2182 argv[0] = "remove-path";
2183 cmdRemovePath( 0, interp, 3, (CONST84 char **) argv);
2184 }
2185 null_free((void *) &module);
2186 }
2187
2188 /**
2189 ** Return on success
2190 **/
2191 return( 1);
2192
2193 } /** End of 'Update_LoadedList' **/
2194
2195 /*++++
2196 ** ** Function-Header ***************************************************** **
2197 ** **
2198 ** Function: check_magic **
2199 ** **
2200 ** Description: Check the magic cookie of the file passed as para- **
2201 ** meter if it is a valid module file **
2202 ** Based on check_magic in Richard Elling's **
2203 ** find_by_magic <Richard.Elling"@eng.auburn.edu> **
2204 ** **
2205 ** First Edition: 1991/10/23 **
2206 ** **
2207 ** Parameters: char *filename Name of the file to check **
2208 ** char *magic_name Magic cookie **
2209 ** int magic_len Length of the magic cookie **
2210 ** **
2211 ** Result: int 0 Magic cookie doesn't match or any **
2212 ** I/O error **
2213 ** 1 Success - Magic cookie has matched **
2214 ** **
2215 ** Attached Globals: - **
2216 ** **
2217 ** ************************************************************************ **
2218 ++++*/
2219
check_magic(char * filename,char * magic_name,int magic_len)2220 int check_magic( char *filename,
2221 char *magic_name,
2222 int magic_len)
2223 {
2224 int fd; /** File descriptor for reading in **/
2225 int read_len; /** Number of bytes read **/
2226 char buf[BUFSIZ]; /** Read buffer **/
2227
2228 #if WITH_DEBUGGING_UTIL_2
2229 ErrorLogger( NO_ERR_START, LOC, _proc_check_magic, NULL);
2230 #endif
2231
2232 /**
2233 ** Parameter check. The length of the magic cookie shouldn't exceed the
2234 ** length of out read buffer
2235 **/
2236 if( magic_len > BUFSIZ)
2237 return 0;
2238
2239 /**
2240 ** Open the file and read in as many bytes as required for checking the
2241 ** magic cookie. If there's an I/O error (Unable to open the file or
2242 ** less than magic_len have been read) return on failure.
2243 **/
2244 if( 0 > (fd = open( filename, O_RDONLY)))
2245 if( OK != ErrorLogger( ERR_OPEN, LOC, filename, "reading", NULL))
2246 return( 0); /** -------- EXIT (FAILURE) -------> **/
2247
2248 read_len = read( fd, buf, magic_len);
2249
2250 if( 0 > close(fd))
2251 if( OK != ErrorLogger( ERR_CLOSE, LOC, filename, NULL))
2252 return( 0); /** -------- EXIT (FAILURE) -------> **/
2253
2254 if( read_len < magic_len)
2255 return( 0);
2256
2257 /**
2258 ** Check the magic cookie now
2259 **/
2260 return( !strncmp( buf, magic_name, magic_len));
2261
2262 } /** end of 'check_magic' **/
2263
2264 /*++++
2265 ** ** Function-Header ***************************************************** **
2266 ** **
2267 ** Function: regex_quote **
2268 ** **
2269 ** Description: Copy the passed path into the new path buffer and **
2270 ** devalue '.' and '+' **
2271 ** **
2272 ** First Edition: 1991/10/23 **
2273 ** **
2274 ** Parameters: const char *path Original path **
2275 ** char *newpath Buffer for to copy the new **
2276 ** path in **
2277 ** int len Max length of the new path **
2278 ** **
2279 ** Result: newpath will be filled up with the new, de- **
2280 ** valuated path **
2281 ** **
2282 ** Attached Globals: - **
2283 ** **
2284 ** ************************************************************************ **
2285 ++++*/
2286
regex_quote(const char * path,char * newpath,int len)2287 void regex_quote( const char *path,
2288 char *newpath,
2289 int len)
2290 {
2291 unsigned int path_len = strlen( path); /** Length of the orig. path **/
2292 int i, /** Read index **/
2293 j; /** Write index **/
2294
2295 #if WITH_DEBUGGING_UTIL_2
2296 ErrorLogger( NO_ERR_START, LOC, _proc_cleanse_path, NULL);
2297 #endif
2298
2299 /**
2300 ** Stopping at (len - 1) ensures that the newpath string can be
2301 ** null-terminated below.
2302 **/
2303 for( i=0, j=0; i<path_len && j<(len - 1); i++, j++) {
2304
2305 switch(*path) {
2306 case '.':
2307 case '+':
2308 case '$':
2309 *newpath++ = '\\'; /** devalue '.' and '+' **/
2310 j++;
2311 break;
2312 }
2313
2314 /**
2315 ** Flush the current character into the newpath buffer
2316 **/
2317 *newpath++ = *path++;
2318
2319 } /** for **/
2320
2321 /**
2322 ** Put a string terminator at the newpaths end
2323 **/
2324 *newpath = '\0';
2325
2326 } /** End of 'cleanse_path' **/
2327
2328 /*++++
2329 ** ** Function-Header ***************************************************** **
2330 ** **
2331 ** Function: chop **
2332 ** **
2333 ** Description: Remove '\n' characters from the passed string **
2334 ** **
2335 ** First Edition: 1991/10/23 **
2336 ** **
2337 ** Parameters: char *string String to be chopped **
2338 ** **
2339 ** Result: string The chopped string **
2340 ** **
2341 ** Attached Globals: - **
2342 ** **
2343 ** ************************************************************************ **
2344 ++++*/
2345
chop(const char * string)2346 static char *chop( const char *string)
2347 {
2348 char *s, *t; /** source and target pointers **/
2349
2350 #if WITH_DEBUGGING_UTIL_2
2351 ErrorLogger( NO_ERR_START, LOC, _proc_chop, NULL);
2352 #endif
2353
2354 /**
2355 ** Remove '\n'
2356 **/
2357
2358 s = t = (char *) string;
2359 while( *s) {
2360 if( '\n' == *s)
2361 s++;
2362 else
2363 *t++ = *s++;
2364 }
2365
2366 /**
2367 ** Copy the trailing terminator and return
2368 **/
2369 *t++ = '\0';
2370 return( (char *) string);
2371
2372 } /** End of 'chop' **/
2373
2374 #ifndef HAVE_STRDUP
2375
2376 /*++++
2377 ** ** Function-Header ***************************************************** **
2378 ** **
2379 ** Function: strdup **
2380 ** **
2381 ** Description: Makes new space to put a copy of the given string **
2382 ** into and then copies the string into the new space. **
2383 ** Just like the "standard" strdup(3). **
2384 ** **
2385 ** First Edition: 1991/10/23 **
2386 ** **
2387 ** Parameters: **
2388 ** Result: **
2389 ** Attached Globals: **
2390 ** **
2391 ** ************************************************************************ **
2392 ++++*/
2393
strdup(char * str)2394 char *strdup( char *str)
2395 {
2396 char* new;
2397 if ((char *) NULL) == (new = stringer(NULL,0, str, NULL))
2398 if( OK != ErrorLogger( ERR_STRING, LOC, filename, NULL))
2399 return( (char*) NULL); /** -------- EXIT (FAILURE) -------> **/
2400 return( new); /** -------- EXIT (SUCCESS) -------> **/
2401 }
2402 #endif /* HAVE_STRDUP */
2403
2404
2405 /*++++
2406 ** ** Function-Header ***************************************************** **
2407 ** **
2408 ** Function: xstrtok_r,xstrtok **
2409 ** **
2410 ** Description: Considers the string s to consist of a sequence of **
2411 ** zero or more text tokens separated by spans of one **
2412 ** or more characters from the separator string delim. **
2413 ** Just like the "standard" strtok(3), and the
2414 ** reentrant version strtok_r(3). **
2415 ** Except this tokenizer will return "empty" tokens too.**
2416 ** Providing our own strtok() eliminates the various **
2417 ** nuances of different implementations. **
2418 ** **
2419 ** First Edition: 2006/04/17 R.K.Owen <rk@owen.sj.ca.us> **
2420 ** **
2421 ** Parameters: **
2422 ** Result: **
2423 ** Attached Globals: **
2424 ** **
2425 ** ************************************************************************ **
2426 ++++*/
2427
xstrtok_r(char * s,const char * delim,char ** ptrptr)2428 char *xstrtok_r(char *s, const char *delim, char **ptrptr) {
2429 register char *ptr, *lptr;
2430 register int c,sc;
2431 const char *tok;
2432
2433 /* return NULL if NULL string and at end of the line */
2434 if (s == NULL && *ptrptr == NULL)
2435 return (NULL);
2436
2437 /* do not skip leading (or trailing) delimiters ... */
2438
2439 /* if non-NULL string then at beginning of token parsing */
2440 if (s != NULL) *ptrptr = s;
2441
2442 ptr = *ptrptr;
2443 while (ptr && *ptr) {
2444 /* cycle through delimiters */
2445 tok = delim;
2446 while (tok && *tok) {
2447 if (*ptr == *tok) { /* match */
2448 *ptr = '\0'; /* null terminate */
2449 lptr = *ptrptr;
2450 *ptrptr = ++ptr; /* set for next time */
2451 return lptr;
2452 }
2453 tok++;
2454 }
2455 ptr++;
2456 }
2457 /* didn't find delimiter */
2458 lptr = *ptrptr;
2459 *ptrptr = NULL;
2460 return lptr;
2461 } /** End of 'xstrtok_r' **/
2462
xstrtok(char * s,const char * delim)2463 char *xstrtok(char *s, const char *delim) {
2464 static char *last;
2465 return xstrtok_r(s,delim,&last);
2466 } /** End of 'xstrtok' **/
2467
2468 #if 0
2469 void tryxstrtok (char *string, char *delim) {
2470 char *start, *str;
2471 char *token;
2472 int n = 1;
2473
2474 start = str = strdup(string);
2475 printf("string: %s\n", str);
2476 printf("delim : %s\n", delim);
2477
2478 token = xstrtok(str,delim);
2479 printf("\t%d = %s\n", n, token);
2480 while (token = xstrtok(NULL, delim)) {
2481 printf("\t%d = %s\n", ++n, token);
2482 }
2483 free(start);
2484 }
2485 int main () {
2486 tryxstrtok("abc:def;ghi,jkl", ":;,");
2487 tryxstrtok(":abc:def;ghi,jkl", ":;,");
2488 tryxstrtok("::abc:def;ghi,jkl", ":;,");
2489 tryxstrtok("abc:def;ghi,jkl:", ":;,");
2490 tryxstrtok("abc:def;ghi,jkl::", ":;,");
2491 tryxstrtok("abc", ":;,");
2492 tryxstrtok("", ":;,");
2493 }
2494 #endif
2495
2496 /*++++
2497 ** ** Function-Header ***************************************************** **
2498 ** **
2499 ** Function: chk4spch **
2500 ** **
2501 ** Description: goes through the given string and changes any non- **
2502 ** printable characters to question marks. **
2503 ** **
2504 ** First Edition: 1991/10/23 **
2505 ** **
2506 ** Parameters: char *s String to be checke **
2507 ** **
2508 ** Result: *s Will be changed accordingly **
2509 ** **
2510 ** Attached Globals: - **
2511 ** **
2512 ** ************************************************************************ **
2513 ++++*/
2514
chk4spch(char * s)2515 void chk4spch(char* s)
2516 {
2517 for( ; *s; s++)
2518 if( !isgraph( *s)) *s = '?';
2519
2520 } /** End of 'chk4spch' **/
2521
2522 /*++++
2523 ** ** Function-Header ***************************************************** **
2524 ** **
2525 ** Function: module_malloc **
2526 ** module_realloc **
2527 ** **
2528 ** Description: A wrapper for the system malloc(),realloc() function **
2529 ** so the argument can be tested and set to a positive **
2530 ** value. **
2531 ** **
2532 ** First Edition: 2007/02/14 R.K.Owen <rk@owen.sj.ca.us> **
2533 ** **
2534 ** Parameters: size_t size Number of bytes to allocate **
2535 ** **
2536 ** Result: void * An allocated memory pointer **
2537 ** **
2538 ** ************************************************************************ **
2539 ++++*/
2540
2541
module_malloc(size_t size)2542 void *module_malloc(size_t size) {
2543 void *ret;
2544
2545 if (size == 0) size = 1;
2546 #ifdef TCL_MEM_DEBUG
2547 ret = ckalloc(size);
2548 #else
2549 ret = malloc(size);
2550 #endif
2551 ret = memset(ret,'\0',size);
2552
2553 return ret;
2554 } /** End of 'module_malloc' **/
2555
module_realloc(void * ptr,size_t size)2556 void *module_realloc(void * ptr, size_t size) {
2557 void *ret;
2558
2559 #ifdef TCL_MEM_DEBUG
2560 ret = ckrealloc(ptr, size);
2561 #else
2562 ret = realloc(ptr, size);
2563 #endif
2564
2565 return ret;
2566 } /** End of 'module_realloc' **/
2567
2568 /*++++
2569 ** ** Function-Header ***************************************************** **
2570 ** **
2571 ** Function: xdup **
2572 ** **
2573 ** Description: will return a string with 1 level of environment **
2574 ** variables expanded. The limit is MOD_BUFSIZE. **
2575 ** An env.var. is denoted with either $name or ${name} **
2576 ** \$ escapes the expansion and substitutes a '$' in **
2577 ** its place. **
2578 ** **
2579 ** First Edition: 2000/01/21 R.K.Owen <rk@owen.sj.ca.us> **
2580 ** **
2581 ** Parameters: char *string Environment variable **
2582 ** **
2583 ** Result: char * An allocated string **
2584 ** **
2585 ** ************************************************************************ **
2586 ++++*/
2587
2588
xdup(char const * string)2589 char *xdup(char const *string) {
2590 char *result = NULL;
2591 char *dollarptr;
2592
2593 if (string == (char *)NULL) return result;
2594
2595 /** need to work from copy of string **/
2596 if (((char *) NULL) == (result = stringer(NULL,0, string, NULL)))
2597 if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
2598 return( (char*) NULL); /** -------- EXIT (FAILURE) -------> **/
2599
2600 /** check for '$' else just pass strdup of it **/
2601 if ((dollarptr = strchr(result, '$')) == (char *) NULL) {
2602 return result;
2603 } else {
2604 /** found something **/
2605 char const *envvar;
2606 char buffer[MOD_BUFSIZE];
2607 char oldbuffer[MOD_BUFSIZE];
2608 size_t blen = 0; /** running buffer length **/
2609 char *slashptr = result;/** where to continue parsing **/
2610 char slashchr; /** store slash char **/
2611 int brace; /** flag if ${name} **/
2612 pid_t pid; /** the process id **/
2613
2614 /** zero out buffers */
2615 memset( buffer, '\0', MOD_BUFSIZE);
2616 memset(oldbuffer, '\0', MOD_BUFSIZE);
2617
2618 /** copy everything upto $ into old buffer **/
2619 *dollarptr = '\0';
2620 strncpy(oldbuffer, slashptr, MOD_BUFSIZE-1);
2621 *dollarptr = '$';
2622
2623 while (dollarptr) {
2624 if (*oldbuffer) strncpy(buffer, oldbuffer, MOD_BUFSIZE);
2625 blen = strlen(buffer);
2626
2627 brace = 0;
2628 /** get the env.var. name **/
2629 if (*(dollarptr + 1) == '{') {
2630 brace = 1;
2631 slashptr = strchr(dollarptr + 1, '}');
2632 } else if (*(dollarptr + 1) == '$') {
2633 slashptr = dollarptr + 2;
2634 } else {
2635 slashptr = dollarptr + 1
2636 + strcspn(dollarptr + 1,"/:$\\");
2637 brace = 0;
2638 }
2639 if (*slashptr) {
2640 slashchr = *slashptr;
2641 *slashptr = '\0';
2642 } else slashptr = (char *)NULL;
2643
2644 /** see if escaped **/
2645 if ((result != dollarptr) && *(dollarptr - 1) == '\\') {
2646 /** replace \ with 0 and copy rest of name **/
2647 buffer[blen - 1] = '\0';
2648 strncat(buffer, dollarptr, MOD_BUFSIZE-blen);
2649 blen = strlen(buffer);
2650 if(brace)
2651 strncat(buffer,"}",MOD_BUFSIZE-blen-1);
2652 } else {
2653 if (! strcmp(dollarptr + 1 + brace, "$")) {
2654 /** put in the process pid **/
2655 pid = getpid();
2656 snprintf(buffer + blen,MOD_BUFSIZE-blen,"%ld",(long)pid);
2657 } else {
2658 /** get env.var. value **/
2659 envvar = getenv(dollarptr + 1 + brace);
2660
2661 /** cat value to rest of string **/
2662 if (envvar) strncat(buffer,envvar,
2663 MOD_BUFSIZE-blen-1);
2664 }
2665 }
2666 blen = strlen(buffer);
2667
2668 /** start at slashptr and find next $ **/
2669 if (slashptr) {
2670 *slashptr = slashchr;
2671 dollarptr = strchr(slashptr, '$');
2672 /** copy everything upto $ **/
2673 if (dollarptr) *dollarptr = '\0';
2674 strncat(buffer, slashptr + brace,
2675 MOD_BUFSIZE -blen -1);
2676 if (dollarptr) {
2677 *dollarptr = '$';
2678 strncpy(oldbuffer, buffer, MOD_BUFSIZE);
2679 }
2680 } else { /** no more to show **/
2681 dollarptr = (char *)NULL;
2682 }
2683 }
2684 null_free((void *) &result);
2685 return stringer(NULL,0, buffer, NULL);
2686 }
2687
2688 } /** End of 'xdup' **/
2689
2690 /*++++
2691 ** ** Function-Header ***************************************************** **
2692 ** **
2693 ** Function: xgetenv **
2694 ** **
2695 ** Description: will return an expanded environment variable. **
2696 ** However, it will only expand 1 level. **
2697 ** See xdup() for details. **
2698 ** **
2699 ** First Edition: 2000/01/18 R.K.Owen <rk@owen.sj.ca.us> **
2700 ** **
2701 ** Parameters: char *var Environment variable **
2702 ** **
2703 ** Result: char * An allocated string **
2704 ** **
2705 ** Attached Globals: - **
2706 ** **
2707 ** ************************************************************************ **
2708 ++++*/
2709
xgetenv(char const * var)2710 char *xgetenv(char const * var) {
2711 char *result = NULL;
2712
2713 if (var == (char *)NULL) return result;
2714
2715 return xdup(getenv(var));
2716
2717 } /** End of 'xgetenv' **/
2718
2719 /*++++
2720 ** ** Function-Header ***************************************************** **
2721 ** **
2722 ** Function: EscapeCshString(char* in,char* out) **
2723 ** **
2724 ** Description: will translate input string to escaped output string **
2725 ** out must be allocated first **
2726 ** **
2727 ** First Edition: 2002/04/10 **
2728 ** **
2729 ** Parameters: char *in input **
2730 ** char *out output **
2731 ** **
2732 ** Attached Globals: - **
2733 ** **
2734 ** ************************************************************************ **
2735 ++++*/
2736
EscapeCshString(const char * in,char * out)2737 void EscapeCshString(const char* in,
2738 char* out) {
2739
2740 for(;*in;in++) {
2741 if (*in == ' ' ||
2742 *in == '\t'||
2743 *in == '\\'||
2744 *in == '{' ||
2745 *in == '}' ||
2746 *in == '|' ||
2747 *in == '<' ||
2748 *in == '>' ||
2749 *in == '!' ||
2750 *in == ';' ||
2751 *in == '#' ||
2752 *in == '$' ||
2753 *in == '^' ||
2754 *in == '&' ||
2755 *in == '*' ||
2756 *in == '\''||
2757 *in == '"' ||
2758 *in == '(' ||
2759 *in == ')') {
2760 *out++ = '\\';
2761 }
2762 *out++ = *in;
2763 }
2764 *out = 0;
2765 }
2766
EscapeShString(const char * in,char * out)2767 void EscapeShString(const char* in,
2768 char* out) {
2769
2770 for(;*in;in++) {
2771 if (*in == ' ' ||
2772 *in == '\t'||
2773 *in == '\\'||
2774 *in == '{' ||
2775 *in == '}' ||
2776 *in == '|' ||
2777 *in == '<' ||
2778 *in == '>' ||
2779 *in == '!' ||
2780 *in == ';' ||
2781 *in == '#' ||
2782 *in == '$' ||
2783 *in == '^' ||
2784 *in == '&' ||
2785 *in == '*' ||
2786 *in == '\''||
2787 *in == '"' ||
2788 *in == '(' ||
2789 *in == ')') {
2790 *out++ = '\\';
2791 }
2792 *out++ = *in;
2793 }
2794 *out = 0;
2795 }
2796
EscapePerlString(const char * in,char * out)2797 void EscapePerlString(const char* in,
2798 char* out) {
2799
2800 for(;*in;in++) {
2801 if (*in == '\\'||
2802 *in == ';' ||
2803 *in == '\'') {
2804 *out++ = '\\';
2805 }
2806 *out++ = *in;
2807 }
2808 *out = 0;
2809 }
2810
2811 /* I think this needs a bunch of work --NJW */
EscapeCmakeString(const char * in,char * out)2812 void EscapeCmakeString(const char* in,
2813 char* out) {
2814 for(;*in;in++) {
2815 if (*in == '\\'||
2816 *in == '"') {
2817 *out++ = '\\';
2818 }
2819 *out++ = *in;
2820 }
2821 *out = 0;
2822 }
2823
2824 /*++++
2825 ** ** Function-Header ***************************************************** **
2826 ** **
2827 ** Function: tmpfile_mod **
2828 ** **
2829 ** Description: emulates tempnam and tmpnam and mktemp **
2830 ** Atomically creates a unique temp file and opens it **
2831 ** for writing. returns 0 on success, 1 on failure **
2832 ** Filename and file handle are returned through **
2833 ** argument pointers **
2834 ** **
2835 ** First Edition: 2002/04/22 **
2836 ** **
2837 ** Parameters: char **filename pointer to char* **
2838 ** char **file pointer to FILE* **
2839 ** **
2840 ** Attached Globals: - **
2841 ** **
2842 ** ************************************************************************ **
2843 ++++*/
2844
tmpfile_mod(char ** filename,FILE ** file)2845 int tmpfile_mod(char** filename, FILE** file) {
2846 char* filename2;
2847 FILE* f = NULL;
2848 int trial = 0;
2849
2850 if ((char *) NULL == (filename2 =
2851 stringer(NULL, strlen(TMP_DIR)+strlen("modulesource")+20, NULL)))
2852 if( OK != ErrorLogger( ERR_STRING, LOC, NULL))
2853 return 1;
2854
2855 do {
2856 int fildes;
2857
2858 sprintf(filename2,"%s/modulesource_%d",TMP_DIR,trial++);
2859 fildes = open(filename2,O_WRONLY | O_CREAT | O_EXCL | O_TRUNC,0755);
2860 #if 0
2861 fprintf(stderr,"DEBUG: filename=%s fildes=%d\n",
2862 filename2,fildes);
2863 #endif
2864 if (fildes >=0) {
2865 *file = fdopen(fildes,"w");
2866 *filename = filename2;
2867 return 0;
2868 }
2869 } while (trial < 1000);
2870
2871 null_free((void *) &filename2);
2872 fprintf(stderr,
2873 "FATAL: could not get a temp file! at %s(%d)",__FILE__,__LINE__);
2874
2875 return 1;
2876 }
2877
2878
2879 /*++++
2880 ** ** Function-Header ***************************************************** **
2881 ** **
2882 ** Function: stringer **
2883 ** **
2884 ** Description: Safely copies and concats series of strings **
2885 ** until it hits a NULL argument. **
2886 ** Either a buffer & length are given or if the buffer **
2887 ** pointer is NULL then it will allocate memory to the **
2888 ** given length. If the length is 0 then get the length **
2889 ** from the series of strings. **
2890 ** The resultant buffer is returned unless there **
2891 ** is an error then NULL is returned. **
2892 ** (Therefore, one of the main uses of stringer is to **
2893 ** allocate string memory.) **
2894 ** **
2895 ** **
2896 ** First Edition: 2001/08/08 R.K.Owen <rk@owen.sj.ca.us> **
2897 ** **
2898 ** Parameters: char *buffer string buffer (if not NULL) **
2899 ** int len maximum length of buffer **
2900 ** const char *str1 1st string to copy to buffer **
2901 ** const char *str2 2nd string to cat to buffer **
2902 ** ... **
2903 ** const char *strN Nth string to cat to buffer **
2904 ** const char *NULL end of arguments **
2905 ** **
2906 ** Result: char *buffer if successful completion **
2907 ** else NULL **
2908 ** **
2909 ** Attached Globals: - **
2910 ** **
2911 ** ************************************************************************ **
2912 ++++*/
2913
stringer(char * buffer,int len,...)2914 char *stringer( char * buffer,
2915 int len,
2916 ... )
2917 {
2918 va_list argptr; /** stdarg argument ptr **/
2919 char *ptr; /** argument string ptr **/
2920 char *tbuf = buffer; /** tempory buffer ptr **/
2921 int sumlen = 0; /** length of all the concat strings **/
2922 char *(*strfn)(char*,const char*) = strcpy;
2923 /** ptr to 1st string function **/
2924
2925 #if WITH_DEBUGGING_UTIL_2
2926 ErrorLogger( NO_ERR_START, LOC, _proc_stringer, NULL);
2927 #endif
2928
2929 /* get start of optional arguments and sum string lengths */
2930 va_start(argptr, len);
2931 while ((ptr = va_arg(argptr, char *))) {
2932 sumlen += strlen(ptr);
2933 }
2934 va_end(argptr);
2935
2936 /* can we even proceed? */
2937 if (tbuf && (sumlen >= len || len < 0)) {
2938 return (char *) NULL;
2939 }
2940
2941 /* do we need to allocate memory? */
2942 if (tbuf == (char *) NULL) {
2943 if (len == 0) {
2944 len = sumlen + 1;
2945 }
2946 if ((char *) NULL == (tbuf = (char*) module_malloc(len))) {
2947 if( OK != ErrorLogger( ERR_ALLOC, LOC, NULL))
2948 return (char *) NULL;
2949 }
2950 }
2951
2952 /* concat all the strings to buffer */
2953 va_start(argptr, len);
2954 while ((ptr = va_arg(argptr, char *))) {
2955 strfn(tbuf, ptr);
2956 strfn = strcat;
2957 }
2958 va_end(argptr);
2959
2960 /* got here successfully - return buffer */
2961 return tbuf;
2962
2963 } /** End of 'stringer' **/
2964
2965 /*++++
2966 ** ** Function-Header ***************************************************** **
2967 ** **
2968 ** Function: null_free **
2969 ** **
2970 ** Description: does a free and then nulls the pointer. **
2971 ** **
2972 ** first edition: 2000/08/24 r.k.owen <rk@owen.sj.ca.us> **
2973 ** **
2974 ** parameters: void **var allocated memory **
2975 ** **
2976 ** result: void (nothing) **
2977 ** **
2978 ** attached globals: - **
2979 ** **
2980 ** ************************************************************************ **
2981 ++++*/
2982
null_free(void ** var)2983 void null_free(void ** var) {
2984
2985 if (! *var) return; /* passed in a NULL ptr */
2986
2987 #ifdef USE_FREE
2988 # ifdef TCL_MEM_DEBUG
2989 ckfree( *var);
2990 # else
2991 free( *var);
2992 # endif
2993 #endif
2994 *var = NULL;
2995
2996 } /** End of 'null_free' **/
2997
2998 /*++++
2999 ** ** Function-Header ***************************************************** **
3000 ** **
3001 ** Function: countTclHash **
3002 ** **
3003 ** Description: returns the number of hash entries in a TclHash **
3004 ** **
3005 ** first edition: 2005/09/01 R.K.Owen <rk@owen.sj.ca.us> **
3006 ** **
3007 ** Parameters: Tcl_HashTable *table Hash to count **
3008 ** **
3009 ** Result: size_t Count of Hash Entries **
3010 ** **
3011 ** Attached Globals: - **
3012 ** **
3013 ** ************************************************************************ **
3014 ++++*/
3015
3016
countTclHash(Tcl_HashTable * table)3017 size_t countTclHash(Tcl_HashTable *table) {
3018 size_t result = 0;
3019 Tcl_HashSearch searchPtr; /** Tcl hash search handle **/
3020
3021 if(Tcl_FirstHashEntry(table, &searchPtr)) {
3022
3023 do {
3024 result++;
3025 } while(Tcl_NextHashEntry( &searchPtr));
3026
3027 } /** if **/
3028
3029 return result;
3030 } /** End of 'countHashTable' **/
3031
3032 /*++++
3033 ** ** Function-Header ***************************************************** **
3034 ** **
3035 ** Function: ReturnValue **
3036 ** **
3037 ** Description: Handles the various possible return values **
3038 ** **
3039 ** first edition: 2006/02/13 R.K.Owen <rk@owen.sj.ca.us> **
3040 ** **
3041 ** Parameters: Tcl_Interp *interp Attached Tcl Interp. **
3042 ** int retval Return value to check**
3043 ** **
3044 ** Result: EM_RetVal Limited set **
3045 ** **
3046 ** Attached Globals: g_retval set to N if "exit N" **
3047 ** **
3048 ** ************************************************************************ **
3049 ++++*/
3050
3051
ReturnValue(Tcl_Interp * interp,int retval)3052 EM_RetVal ReturnValue(Tcl_Interp *interp, int retval) {
3053 EM_RetVal em_result;
3054 char *startp = (char *) NULL,
3055 *endp = (char *) NULL;
3056 const char *tstr;
3057 int result;
3058 static char *Exit_ = "^EXIT ([0-9]*)",
3059 *Break = ".*\"break\".*",
3060 *Cont = ".*\"continue\".*";
3061 static Tcl_Obj *exit_Ptr = (Tcl_Obj *) NULL,
3062 *break_Ptr = (Tcl_Obj *) NULL,
3063 *cont_Ptr = (Tcl_Obj *) NULL;
3064 static Tcl_RegExp exit__expPtr = (Tcl_RegExp) NULL,
3065 break_expPtr = (Tcl_RegExp) NULL,
3066 cont_expPtr = (Tcl_RegExp) NULL;
3067
3068 tstr = (const char *) TCL_RESULT(interp);
3069
3070 /* compile regular expression the first time through */
3071 if (!exit_Ptr)
3072 exit_Ptr = Tcl_NewStringObj(Exit_,strlen(Exit_));
3073 if (!exit__expPtr)
3074 exit__expPtr = Tcl_GetRegExpFromObj(interp,
3075 exit_Ptr,TCL_REG_ADVANCED);
3076
3077 /* result = "invoked \"break\" outside of a loop" */
3078 if (!break_Ptr)
3079 break_Ptr = Tcl_NewStringObj(Break,strlen(Break));
3080 if (!break_expPtr)
3081 break_expPtr = Tcl_GetRegExpFromObj(interp,
3082 break_Ptr,TCL_REG_ADVANCED);
3083
3084 /* result = "invoked \"continue\" outside of a loop" */
3085 if (!cont_Ptr)
3086 cont_Ptr = Tcl_NewStringObj(Cont,strlen(Cont));
3087 if (!cont_expPtr)
3088 cont_expPtr = Tcl_GetRegExpFromObj(interp,
3089 cont_Ptr,TCL_REG_ADVANCED);
3090
3091 /* intercept any "EXIT N" first */
3092 if(tstr && *tstr && 0 < Tcl_RegExpExec(interp, exit__expPtr,
3093 (CONST84 char *) tstr, (CONST84 char *) tstr)){
3094 /* found 'EXIT' */
3095 Tcl_RegExpRange(exit__expPtr, 1,
3096 (CONST84 char **) &startp, (CONST84 char **) &endp);
3097 if( startp && *startp != '\0')
3098 result = atoi((const char *) startp);
3099 else
3100 result = 0;
3101
3102 g_retval = result;
3103 em_result = EM_EXIT;
3104
3105 /* check for a break not within loop */
3106 } else if(tstr && *tstr && 0 < Tcl_RegExpExec(interp, break_expPtr,
3107 (CONST84 char *) tstr, (CONST84 char *) tstr)){
3108 em_result = EM_BREAK;
3109
3110 /* check for a continue not within loop */
3111 } else if(tstr && *tstr && 0 < Tcl_RegExpExec(interp, cont_expPtr,
3112 (CONST84 char *) tstr, (CONST84 char *) tstr)){
3113 em_result = EM_CONTINUE;
3114
3115 } else {
3116 switch (retval) {
3117 case TCL_OK:
3118 em_result = EM_OK;
3119 break;
3120 case TCL_BREAK:
3121 em_result = EM_BREAK;
3122 break;
3123 case TCL_CONTINUE:
3124 em_result = EM_CONTINUE;
3125 break;
3126 case TCL_ERROR:
3127 default:
3128 em_result = EM_ERROR;
3129 break;
3130 }
3131 }
3132 return em_result;
3133 } /** End of 'ReturnValue' **/
3134
3135 /*++++
3136 ** ** Function-Header ***************************************************** **
3137 ** **
3138 ** Function: OutputExit **
3139 ** **
3140 ** Description: Outputs a 'test 0 = 1' line so command will eval **
3141 ** with a non-zero exit code **
3142 ** **
3143 ** first edition: 2006/03/07 R.K.Owen <rk@owen.sj.ca.us> **
3144 ** **
3145 ** Parameters: void none **
3146 ** **
3147 ** result: void (nothing) **
3148 ** **
3149 ** Attached Globals: g_retval if non-zero **
3150 ** g_output if non-zero **
3151 ** **
3152 ** ************************************************************************ **
3153 ++++*/
OutputExit()3154 void OutputExit() {
3155
3156 if (shell_derelict == NULL) {
3157 return;
3158 } else if( !strcmp( shell_derelict, "csh")) {
3159 /* OK shell derelict */
3160 } else if( !strcmp( shell_derelict, "sh")) {
3161 /* OK shell derelict */
3162 } else {
3163 return;
3164 }
3165 if (g_retval) {
3166 fprintf( stdout, " test 0 = 1;");
3167 }
3168 } /** End of 'OutputExit' **/
3169
3170 /*++++
3171 ** ** Function-Header ***************************************************** **
3172 ** **
3173 ** Function: EMGetEnv **
3174 ** **
3175 ** Description: Wrap the Tcl_GetVar2() call and return an allocated **
3176 ** string **
3177 ** **
3178 ** first edition: 2011/08/15 R.K.Owen <rk@owen.sj.ca.us> **
3179 ** **
3180 ** Parameters: Tcl_Interp *interp TCL interp. **
3181 ** char *var Environment variable **
3182 ** **
3183 ** Result: char * An allocated string **
3184 ** **
3185 ** ************************************************************************ **
3186 ++++*/
EMGetEnv(Tcl_Interp * interp,char const * var)3187 char * EMGetEnv( Tcl_Interp *interp,
3188 char const *var) {
3189
3190 char *value, *string;
3191
3192 Tcl_Preserve(interp);
3193 value = (char *) Tcl_GetVar2( interp, "env", var, TCL_GLOBAL_ONLY);
3194 Tcl_Release(interp);
3195 string = stringer(NULL, 0, value, NULL);
3196
3197 if(!string)
3198 if (OK != ErrorLogger(ERR_ALLOC, LOC, NULL))
3199 return (NULL); /** ---- EXIT (FAILURE) ---> **/
3200
3201 return string;
3202
3203 } /** End of 'EMGetEnv' **/
3204
3205 /*++++
3206 ** ** Function-Header ***************************************************** **
3207 ** **
3208 ** Function: EMSetEnv **
3209 ** **
3210 ** Description: Wrap the Tcl_SetVar2() call and return an allocated **
3211 ** string **
3212 ** **
3213 ** first edition: 2011/09/26 R.K.Owen <rk@owen.sj.ca.us> **
3214 ** **
3215 ** Parameters: Tcl_Interp *interp TCL interp. **
3216 ** char *var Environment variable **
3217 ** char *val New value **
3218 ** **
3219 ** Result: char * current value string **
3220 ** **
3221 ** ************************************************************************ **
3222 ++++*/
EMSetEnv(Tcl_Interp * interp,char const * var,char const * val)3223 char * EMSetEnv( Tcl_Interp *interp,
3224 char const *var,
3225 char const *val) {
3226
3227 char *value;
3228
3229 Tcl_Preserve(interp);
3230 value = (char *) Tcl_SetVar2( interp, "env", var, val, TCL_GLOBAL_ONLY);
3231 Tcl_Release(interp);
3232
3233 return value;
3234
3235 } /** End of 'EMSetEnv' **/
3236
3237 /*++++
3238 ** ** Function-Header ***************************************************** **
3239 ** **
3240 ** Function: is_interactive **
3241 ** **
3242 ** Description: Test whether an interactive shell or not **
3243 ** (for bash) **
3244 ** **
3245 ** first edition: 2012/05/21 R.K.Owen <rk@owen.sj.ca.us> **
3246 ** **
3247 ** Parameters: none **
3248 ** **
3249 ** Result: int return 1 if true, else 0 **
3250 ** **
3251 ** ************************************************************************ **
3252 ++++*/
is_interactive(void)3253 int is_interactive(void) {
3254
3255 static int saved = -1;
3256 FILE *tty = (FILE *) NULL;
3257
3258 if (saved < 0) {
3259 /* try /dev/tty */
3260 if (!(tty = fopen("/dev/tty","w"))) {
3261 saved = 0; /* no tty - hence non-interactive */
3262 } else if (isatty(fileno(stdin)) || isatty(fileno(stdout))
3263 || isatty(fileno(stderr))) {
3264 /* at least one of stdin/out/err is a tty */
3265 saved = 1;
3266 } else {
3267 saved = 0;
3268 }
3269 if (tty) fclose(tty);
3270 }
3271
3272 return saved;
3273
3274 } /** End of 'is_interactive' **/
3275