/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclload.c
ViewVC logotype

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclload.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 44 - (hide annotations) (download)
Fri Oct 14 02:09:58 2016 UTC (7 years, 1 month ago) by dashley
File MIME type: text/plain
File size: 20404 byte(s)
Rename for reorganization.
1 dashley 25 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclload.c,v 1.1.1.1 2001/06/13 04:42:55 dtashley Exp $ */
2    
3     /*
4     * tclLoad.c --
5     *
6     * This file provides the generic portion (those that are the same
7     * on all platforms) of Tcl's dynamic loading facilities.
8     *
9     * Copyright (c) 1995-1997 Sun Microsystems, Inc.
10     *
11     * See the file "license.terms" for information on usage and redistribution
12     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13     *
14     * RCS: @(#) $Id: tclload.c,v 1.1.1.1 2001/06/13 04:42:55 dtashley Exp $
15     */
16    
17     #include "tclInt.h"
18    
19     /*
20     * The following structure describes a package that has been loaded
21     * either dynamically (with the "load" command) or statically (as
22     * indicated by a call to TclGetLoadedPackages). All such packages
23     * are linked together into a single list for the process. Packages
24     * are never unloaded, so these structures are never freed.
25     */
26    
27     typedef struct LoadedPackage {
28     char *fileName; /* Name of the file from which the
29     * package was loaded. An empty string
30     * means the package is loaded statically.
31     * Malloc-ed. */
32     char *packageName; /* Name of package prefix for the package,
33     * properly capitalized (first letter UC,
34     * others LC), no "_", as in "Net".
35     * Malloc-ed. */
36     ClientData clientData; /* Token for the loaded file which should be
37     * passed to TclpUnloadFile() when the file
38     * is no longer needed. If fileName is NULL,
39     * then this field is irrelevant. */
40     Tcl_PackageInitProc *initProc;
41     /* Initialization procedure to call to
42     * incorporate this package into a trusted
43     * interpreter. */
44     Tcl_PackageInitProc *safeInitProc;
45     /* Initialization procedure to call to
46     * incorporate this package into a safe
47     * interpreter (one that will execute
48     * untrusted scripts). NULL means the
49     * package can't be used in unsafe
50     * interpreters. */
51     struct LoadedPackage *nextPtr;
52     /* Next in list of all packages loaded into
53     * this application process. NULL means
54     * end of list. */
55     } LoadedPackage;
56    
57     /*
58     * TCL_THREADS
59     * There is a global list of packages that is anchored at firstPackagePtr.
60     * Access to this list is governed by a mutex.
61     */
62    
63     static LoadedPackage *firstPackagePtr = NULL;
64     /* First in list of all packages loaded into
65     * this process. */
66    
67     TCL_DECLARE_MUTEX(packageMutex)
68    
69     /*
70     * The following structure represents a particular package that has
71     * been incorporated into a particular interpreter (by calling its
72     * initialization procedure). There is a list of these structures for
73     * each interpreter, with an AssocData value (key "load") for the
74     * interpreter that points to the first package (if any).
75     */
76    
77     typedef struct InterpPackage {
78     LoadedPackage *pkgPtr; /* Points to detailed information about
79     * package. */
80     struct InterpPackage *nextPtr;
81     /* Next package in this interpreter, or
82     * NULL for end of list. */
83     } InterpPackage;
84    
85     /*
86     * Prototypes for procedures that are private to this file:
87     */
88    
89     static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData,
90     Tcl_Interp *interp));
91    
92     /*
93     *----------------------------------------------------------------------
94     *
95     * Tcl_LoadObjCmd --
96     *
97     * This procedure is invoked to process the "load" Tcl command.
98     * See the user documentation for details on what it does.
99     *
100     * Results:
101     * A standard Tcl result.
102     *
103     * Side effects:
104     * See the user documentation.
105     *
106     *----------------------------------------------------------------------
107     */
108    
109     int
110     Tcl_LoadObjCmd(dummy, interp, objc, objv)
111     ClientData dummy; /* Not used. */
112     Tcl_Interp *interp; /* Current interpreter. */
113     int objc; /* Number of arguments. */
114     Tcl_Obj *CONST objv[]; /* Argument objects. */
115     {
116     Tcl_Interp *target;
117     LoadedPackage *pkgPtr, *defaultPtr;
118     Tcl_DString pkgName, tmp, initName, safeInitName, fileName;
119     Tcl_PackageInitProc *initProc, *safeInitProc;
120     InterpPackage *ipFirstPtr, *ipPtr;
121     int code, namesMatch, filesMatch;
122     char *p, *tempString, *fullFileName, *packageName;
123     ClientData clientData;
124     Tcl_UniChar ch;
125     int offset;
126    
127     if ((objc < 2) || (objc > 4)) {
128     Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
129     return TCL_ERROR;
130     }
131     tempString = Tcl_GetString(objv[1]);
132     fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName);
133     if (fullFileName == NULL) {
134     return TCL_ERROR;
135     }
136     Tcl_DStringInit(&pkgName);
137     Tcl_DStringInit(&initName);
138     Tcl_DStringInit(&safeInitName);
139     Tcl_DStringInit(&tmp);
140    
141     packageName = NULL;
142     if (objc >= 3) {
143     packageName = Tcl_GetString(objv[2]);
144     if (packageName[0] == '\0') {
145     packageName = NULL;
146     }
147     }
148     if ((fullFileName[0] == 0) && (packageName == NULL)) {
149     Tcl_SetResult(interp,
150     "must specify either file name or package name",
151     TCL_STATIC);
152     code = TCL_ERROR;
153     goto done;
154     }
155    
156     /*
157     * Figure out which interpreter we're going to load the package into.
158     */
159    
160     target = interp;
161     if (objc == 4) {
162     char *slaveIntName;
163     slaveIntName = Tcl_GetString(objv[3]);
164     target = Tcl_GetSlave(interp, slaveIntName);
165     if (target == NULL) {
166     return TCL_ERROR;
167     }
168     }
169    
170     /*
171     * Scan through the packages that are currently loaded to see if the
172     * package we want is already loaded. We'll use a loaded package if
173     * it meets any of the following conditions:
174     * - Its name and file match the once we're looking for.
175     * - Its file matches, and we weren't given a name.
176     * - Its name matches, the file name was specified as empty, and there
177     * is only no statically loaded package with the same name.
178     */
179     Tcl_MutexLock(&packageMutex);
180    
181     defaultPtr = NULL;
182     for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
183     if (packageName == NULL) {
184     namesMatch = 0;
185     } else {
186     Tcl_DStringSetLength(&pkgName, 0);
187     Tcl_DStringAppend(&pkgName, packageName, -1);
188     Tcl_DStringSetLength(&tmp, 0);
189     Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
190     Tcl_UtfToLower(Tcl_DStringValue(&pkgName));
191     Tcl_UtfToLower(Tcl_DStringValue(&tmp));
192     if (strcmp(Tcl_DStringValue(&tmp),
193     Tcl_DStringValue(&pkgName)) == 0) {
194     namesMatch = 1;
195     } else {
196     namesMatch = 0;
197     }
198     }
199     Tcl_DStringSetLength(&pkgName, 0);
200    
201     filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
202     if (filesMatch && (namesMatch || (packageName == NULL))) {
203     break;
204     }
205     if (namesMatch && (fullFileName[0] == 0)) {
206     defaultPtr = pkgPtr;
207     }
208     if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
209     /*
210     * Can't have two different packages loaded from the same
211     * file.
212     */
213    
214     Tcl_AppendResult(interp, "file \"", fullFileName,
215     "\" is already loaded for package \"",
216     pkgPtr->packageName, "\"", (char *) NULL);
217     code = TCL_ERROR;
218     Tcl_MutexUnlock(&packageMutex);
219     goto done;
220     }
221     }
222     Tcl_MutexUnlock(&packageMutex);
223     if (pkgPtr == NULL) {
224     pkgPtr = defaultPtr;
225     }
226    
227     /*
228     * Scan through the list of packages already loaded in the target
229     * interpreter. If the package we want is already loaded there,
230     * then there's nothing for us to to.
231     */
232    
233     if (pkgPtr != NULL) {
234     ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
235     (Tcl_InterpDeleteProc **) NULL);
236     for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
237     if (ipPtr->pkgPtr == pkgPtr) {
238     code = TCL_OK;
239     goto done;
240     }
241     }
242     }
243    
244     if (pkgPtr == NULL) {
245     /*
246     * The desired file isn't currently loaded, so load it. It's an
247     * error if the desired package is a static one.
248     */
249    
250     if (fullFileName[0] == 0) {
251     Tcl_AppendResult(interp, "package \"", packageName,
252     "\" isn't loaded statically", (char *) NULL);
253     code = TCL_ERROR;
254     goto done;
255     }
256    
257     /*
258     * Figure out the module name if it wasn't provided explicitly.
259     */
260    
261     if (packageName != NULL) {
262     Tcl_DStringAppend(&pkgName, packageName, -1);
263     } else {
264     int retc;
265     /*
266     * Threading note - this call used to be protected by a mutex.
267     */
268     retc = TclGuessPackageName(fullFileName, &pkgName);
269     if (!retc) {
270     int pargc;
271     char **pargv, *pkgGuess;
272    
273     /*
274     * The platform-specific code couldn't figure out the
275     * module name. Make a guess by taking the last element
276     * of the file name, stripping off any leading "lib",
277     * and then using all of the alphabetic and underline
278     * characters that follow that.
279     */
280    
281     Tcl_SplitPath(fullFileName, &pargc, &pargv);
282     pkgGuess = pargv[pargc-1];
283     if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
284     && (pkgGuess[2] == 'b')) {
285     pkgGuess += 3;
286     }
287     for (p = pkgGuess; *p != 0; p += offset) {
288     offset = Tcl_UtfToUniChar(p, &ch);
289     if ((ch > 0x100)
290     || !(isalpha(UCHAR(ch)) /* INTL: ISO only */
291     || (UCHAR(ch) == '_'))) {
292     break;
293     }
294     }
295     if (p == pkgGuess) {
296     ckfree((char *)pargv);
297     Tcl_AppendResult(interp,
298     "couldn't figure out package name for ",
299     fullFileName, (char *) NULL);
300     code = TCL_ERROR;
301     goto done;
302     }
303     Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));
304     ckfree((char *)pargv);
305     }
306     }
307    
308     /*
309     * Fix the capitalization in the package name so that the first
310     * character is in caps (or title case) but the others are all
311     * lower-case.
312     */
313    
314     Tcl_DStringSetLength(&pkgName,
315     Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));
316    
317     /*
318     * Compute the names of the two initialization procedures,
319     * based on the package name.
320     */
321    
322     Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
323     Tcl_DStringAppend(&initName, "_Init", 5);
324     Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
325     Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
326    
327     /*
328     * Call platform-specific code to load the package and find the
329     * two initialization procedures.
330     */
331    
332     Tcl_MutexLock(&packageMutex);
333     code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),
334     Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
335     &clientData);
336     Tcl_MutexUnlock(&packageMutex);
337     if (code != TCL_OK) {
338     goto done;
339     }
340     if (initProc == NULL) {
341     Tcl_AppendResult(interp, "couldn't find procedure ",
342     Tcl_DStringValue(&initName), (char *) NULL);
343     TclpUnloadFile(clientData);
344     code = TCL_ERROR;
345     goto done;
346     }
347    
348     /*
349     * Create a new record to describe this package.
350     */
351    
352     pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
353     pkgPtr->fileName = (char *) ckalloc((unsigned)
354     (strlen(fullFileName) + 1));
355     strcpy(pkgPtr->fileName, fullFileName);
356     pkgPtr->packageName = (char *) ckalloc((unsigned)
357     (Tcl_DStringLength(&pkgName) + 1));
358     strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
359     pkgPtr->clientData = clientData;
360     pkgPtr->initProc = initProc;
361     pkgPtr->safeInitProc = safeInitProc;
362     Tcl_MutexLock(&packageMutex);
363     pkgPtr->nextPtr = firstPackagePtr;
364     firstPackagePtr = pkgPtr;
365     Tcl_MutexUnlock(&packageMutex);
366     }
367    
368     /*
369     * Invoke the package's initialization procedure (either the
370     * normal one or the safe one, depending on whether or not the
371     * interpreter is safe).
372     */
373    
374     if (Tcl_IsSafe(target)) {
375     if (pkgPtr->safeInitProc != NULL) {
376     code = (*pkgPtr->safeInitProc)(target);
377     } else {
378     Tcl_AppendResult(interp,
379     "can't use package in a safe interpreter: ",
380     "no ", pkgPtr->packageName, "_SafeInit procedure",
381     (char *) NULL);
382     code = TCL_ERROR;
383     goto done;
384     }
385     } else {
386     code = (*pkgPtr->initProc)(target);
387     }
388    
389     /*
390     * Record the fact that the package has been loaded in the
391     * target interpreter.
392     */
393    
394     if (code == TCL_OK) {
395     /*
396     * Refetch ipFirstPtr: loading the package may have introduced
397     * additional static packages at the head of the linked list!
398     */
399    
400     ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
401     (Tcl_InterpDeleteProc **) NULL);
402     ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
403     ipPtr->pkgPtr = pkgPtr;
404     ipPtr->nextPtr = ipFirstPtr;
405     Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
406     (ClientData) ipPtr);
407     } else {
408     TclTransferResult(target, code, interp);
409     }
410    
411     done:
412     Tcl_DStringFree(&pkgName);
413     Tcl_DStringFree(&initName);
414     Tcl_DStringFree(&safeInitName);
415     Tcl_DStringFree(&fileName);
416     Tcl_DStringFree(&tmp);
417     return code;
418     }
419    
420     /*
421     *----------------------------------------------------------------------
422     *
423     * Tcl_StaticPackage --
424     *
425     * This procedure is invoked to indicate that a particular
426     * package has been linked statically with an application.
427     *
428     * Results:
429     * None.
430     *
431     * Side effects:
432     * Once this procedure completes, the package becomes loadable
433     * via the "load" command with an empty file name.
434     *
435     *----------------------------------------------------------------------
436     */
437    
438     void
439     Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
440     Tcl_Interp *interp; /* If not NULL, it means that the
441     * package has already been loaded
442     * into the given interpreter by
443     * calling the appropriate init proc. */
444     char *pkgName; /* Name of package (must be properly
445     * capitalized: first letter upper
446     * case, others lower case). */
447     Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate
448     * this package into a trusted
449     * interpreter. */
450     Tcl_PackageInitProc *safeInitProc; /* Procedure to call to incorporate
451     * this package into a safe interpreter
452     * (one that will execute untrusted
453     * scripts). NULL means the package
454     * can't be used in safe
455     * interpreters. */
456     {
457     LoadedPackage *pkgPtr;
458     InterpPackage *ipPtr, *ipFirstPtr;
459    
460     /*
461     * Check to see if someone else has already reported this package as
462     * statically loaded. If this call is redundant then just return.
463     */
464    
465     Tcl_MutexLock(&packageMutex);
466     for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
467     if ((pkgPtr->initProc == initProc)
468     && (pkgPtr->safeInitProc == safeInitProc)
469     && (strcmp(pkgPtr->packageName, pkgName) == 0)) {
470     Tcl_MutexUnlock(&packageMutex);
471     return;
472     }
473     }
474    
475     Tcl_MutexUnlock(&packageMutex);
476    
477     pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
478     pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
479     pkgPtr->fileName[0] = 0;
480     pkgPtr->packageName = (char *) ckalloc((unsigned)
481     (strlen(pkgName) + 1));
482     strcpy(pkgPtr->packageName, pkgName);
483     pkgPtr->clientData = NULL;
484     pkgPtr->initProc = initProc;
485     pkgPtr->safeInitProc = safeInitProc;
486     Tcl_MutexLock(&packageMutex);
487     pkgPtr->nextPtr = firstPackagePtr;
488     firstPackagePtr = pkgPtr;
489     Tcl_MutexUnlock(&packageMutex);
490    
491     if (interp != NULL) {
492     ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
493     (Tcl_InterpDeleteProc **) NULL);
494     ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
495     ipPtr->pkgPtr = pkgPtr;
496     ipPtr->nextPtr = ipFirstPtr;
497     Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,
498     (ClientData) ipPtr);
499     }
500     }
501    
502     /*
503     *----------------------------------------------------------------------
504     *
505     * TclGetLoadedPackages --
506     *
507     * This procedure returns information about all of the files
508     * that are loaded (either in a particular intepreter, or
509     * for all interpreters).
510     *
511     * Results:
512     * The return value is a standard Tcl completion code. If
513     * successful, a list of lists is placed in the interp's result.
514     * Each sublist corresponds to one loaded file; its first
515     * element is the name of the file (or an empty string for
516     * something that's statically loaded) and the second element
517     * is the name of the package in that file.
518     *
519     * Side effects:
520     * None.
521     *
522     *----------------------------------------------------------------------
523     */
524    
525     int
526     TclGetLoadedPackages(interp, targetName)
527     Tcl_Interp *interp; /* Interpreter in which to return
528     * information or error message. */
529     char *targetName; /* Name of target interpreter or NULL.
530     * If NULL, return info about all interps;
531     * otherwise, just return info about this
532     * interpreter. */
533     {
534     Tcl_Interp *target;
535     LoadedPackage *pkgPtr;
536     InterpPackage *ipPtr;
537     char *prefix;
538    
539     if (targetName == NULL) {
540     /*
541     * Return information about all of the available packages.
542     */
543    
544     prefix = "{";
545     Tcl_MutexLock(&packageMutex);
546     for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
547     pkgPtr = pkgPtr->nextPtr) {
548     Tcl_AppendResult(interp, prefix, (char *) NULL);
549     Tcl_AppendElement(interp, pkgPtr->fileName);
550     Tcl_AppendElement(interp, pkgPtr->packageName);
551     Tcl_AppendResult(interp, "}", (char *) NULL);
552     prefix = " {";
553     }
554     Tcl_MutexUnlock(&packageMutex);
555     return TCL_OK;
556     }
557    
558     /*
559     * Return information about only the packages that are loaded in
560     * a given interpreter.
561     */
562    
563     target = Tcl_GetSlave(interp, targetName);
564     if (target == NULL) {
565     return TCL_ERROR;
566     }
567     ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
568     (Tcl_InterpDeleteProc **) NULL);
569     prefix = "{";
570     for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
571     pkgPtr = ipPtr->pkgPtr;
572     Tcl_AppendResult(interp, prefix, (char *) NULL);
573     Tcl_AppendElement(interp, pkgPtr->fileName);
574     Tcl_AppendElement(interp, pkgPtr->packageName);
575     Tcl_AppendResult(interp, "}", (char *) NULL);
576     prefix = " {";
577     }
578     return TCL_OK;
579     }
580    
581     /*
582     *----------------------------------------------------------------------
583     *
584     * LoadCleanupProc --
585     *
586     * This procedure is called to delete all of the InterpPackage
587     * structures for an interpreter when the interpreter is deleted.
588     * It gets invoked via the Tcl AssocData mechanism.
589     *
590     * Results:
591     * None.
592     *
593     * Side effects:
594     * Storage for all of the InterpPackage procedures for interp
595     * get deleted.
596     *
597     *----------------------------------------------------------------------
598     */
599    
600     static void
601     LoadCleanupProc(clientData, interp)
602     ClientData clientData; /* Pointer to first InterpPackage structure
603     * for interp. */
604     Tcl_Interp *interp; /* Interpreter that is being deleted. */
605     {
606     InterpPackage *ipPtr, *nextPtr;
607    
608     ipPtr = (InterpPackage *) clientData;
609     while (ipPtr != NULL) {
610     nextPtr = ipPtr->nextPtr;
611     ckfree((char *) ipPtr);
612     ipPtr = nextPtr;
613     }
614     }
615    
616     /*
617     *----------------------------------------------------------------------
618     *
619     * TclFinalizeLoad --
620     *
621     * This procedure is invoked just before the application exits.
622     * It frees all of the LoadedPackage structures.
623     *
624     * Results:
625     * None.
626     *
627     * Side effects:
628     * Memory is freed.
629     *
630     *----------------------------------------------------------------------
631     */
632    
633     void
634     TclFinalizeLoad()
635     {
636     LoadedPackage *pkgPtr;
637    
638     /*
639     * No synchronization here because there should just be
640     * one thread alive at this point. Logically,
641     * packageMutex should be grabbed at this point, but
642     * the Mutexes get finalized before the call to this routine.
643     * The only subsystem left alive at this point is the
644     * memory allocator.
645     */
646    
647     while (firstPackagePtr != NULL) {
648     pkgPtr = firstPackagePtr;
649     firstPackagePtr = pkgPtr->nextPtr;
650     #if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
651     /*
652     * Some Unix dlls are poorly behaved - registering things like
653     * atexit calls that can't be unregistered. If you unload
654     * such dlls, you get a core on exit because it wants to
655     * call a function in the dll after it's been unloaded.
656     */
657     if (pkgPtr->fileName[0] != '\0') {
658     TclpUnloadFile(pkgPtr->clientData);
659     }
660     #endif
661     ckfree(pkgPtr->fileName);
662     ckfree(pkgPtr->packageName);
663     ckfree((char *) pkgPtr);
664     }
665     }
666    
667    
668     /* $History: tclload.c $
669     *
670     * ***************** Version 1 *****************
671     * User: Dtashley Date: 1/02/01 Time: 1:32a
672     * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
673     * Initial check-in.
674     */
675    
676     /* End of TCLLOAD.C */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25