OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclLoad.c] - Blame information for rev 1774

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.