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

Contents of /projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclload.c

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25