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

Contents of /projs/trunk/shared_source/tcl_base/tclload.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 42 - (show annotations) (download)
Fri Oct 14 01:50:00 2016 UTC (8 years, 2 months ago) by dashley
File MIME type: text/plain
File size: 20404 byte(s)
Move shared source code to commonize.
1 /* $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