[25] | 1 | /* |
---|
| 2 | * tclLoadDl.c -- |
---|
| 3 | * |
---|
| 4 | * This procedure provides a version of the TclLoadFile that works with |
---|
| 5 | * the "dlopen" and "dlsym" library procedures for dynamic loading. |
---|
| 6 | * |
---|
| 7 | * Copyright (c) 1995-1997 Sun Microsystems, Inc. |
---|
| 8 | * |
---|
| 9 | * See the file "license.terms" for information on usage and redistribution of |
---|
| 10 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 11 | * |
---|
| 12 | * RCS: @(#) $Id: tclLoadDl.c,v 1.16 2006/06/13 22:10:19 dkf Exp $ |
---|
| 13 | */ |
---|
| 14 | |
---|
| 15 | #include "tclInt.h" |
---|
| 16 | #ifdef NO_DLFCN_H |
---|
| 17 | # include "../compat/dlfcn.h" |
---|
| 18 | #else |
---|
| 19 | # include <dlfcn.h> |
---|
| 20 | #endif |
---|
| 21 | |
---|
| 22 | /* |
---|
| 23 | * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined and this |
---|
| 24 | * argument to dlopen must always be 1. The RTLD_GLOBAL flag is needed on some |
---|
| 25 | * systems (e.g. SCO and UnixWare) but doesn't exist on others; if it doesn't |
---|
| 26 | * exist, set it to 0 so it has no effect. |
---|
| 27 | */ |
---|
| 28 | |
---|
| 29 | #ifndef RTLD_NOW |
---|
| 30 | # define RTLD_NOW 1 |
---|
| 31 | #endif |
---|
| 32 | |
---|
| 33 | #ifndef RTLD_GLOBAL |
---|
| 34 | # define RTLD_GLOBAL 0 |
---|
| 35 | #endif |
---|
| 36 | |
---|
| 37 | /* |
---|
| 38 | *--------------------------------------------------------------------------- |
---|
| 39 | * |
---|
| 40 | * TclpDlopen -- |
---|
| 41 | * |
---|
| 42 | * Dynamically loads a binary code file into memory and returns a handle |
---|
| 43 | * to the new code. |
---|
| 44 | * |
---|
| 45 | * Results: |
---|
| 46 | * A standard Tcl completion code. If an error occurs, an error message |
---|
| 47 | * is left in the interp's result. |
---|
| 48 | * |
---|
| 49 | * Side effects: |
---|
| 50 | * New code suddenly appears in memory. |
---|
| 51 | * |
---|
| 52 | *--------------------------------------------------------------------------- |
---|
| 53 | */ |
---|
| 54 | |
---|
| 55 | int |
---|
| 56 | TclpDlopen( |
---|
| 57 | Tcl_Interp *interp, /* Used for error reporting. */ |
---|
| 58 | Tcl_Obj *pathPtr, /* Name of the file containing the desired |
---|
| 59 | * code (UTF-8). */ |
---|
| 60 | Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded |
---|
| 61 | * file which will be passed back to |
---|
| 62 | * (*unloadProcPtr)() to unload the file. */ |
---|
| 63 | Tcl_FSUnloadFileProc **unloadProcPtr) |
---|
| 64 | /* Filled with address of Tcl_FSUnloadFileProc |
---|
| 65 | * function which should be used for this |
---|
| 66 | * file. */ |
---|
| 67 | { |
---|
| 68 | void *handle; |
---|
| 69 | CONST char *native; |
---|
| 70 | |
---|
| 71 | /* |
---|
| 72 | * First try the full path the user gave us. This is particularly |
---|
| 73 | * important if the cwd is inside a vfs, and we are trying to load using a |
---|
| 74 | * relative path. |
---|
| 75 | */ |
---|
| 76 | |
---|
| 77 | native = Tcl_FSGetNativePath(pathPtr); |
---|
| 78 | handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL); |
---|
| 79 | if (handle == NULL) { |
---|
| 80 | /* |
---|
| 81 | * Let the OS loader examine the binary search path for whatever |
---|
| 82 | * string the user gave us which hopefully refers to a file on the |
---|
| 83 | * binary path. |
---|
| 84 | */ |
---|
| 85 | |
---|
| 86 | Tcl_DString ds; |
---|
| 87 | char *fileName = Tcl_GetString(pathPtr); |
---|
| 88 | |
---|
| 89 | native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); |
---|
| 90 | handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL); |
---|
| 91 | Tcl_DStringFree(&ds); |
---|
| 92 | } |
---|
| 93 | |
---|
| 94 | if (handle == NULL) { |
---|
| 95 | /* |
---|
| 96 | * Write the string to a variable first to work around a compiler bug |
---|
| 97 | * in the Sun Forte 6 compiler. [Bug 1503729] |
---|
| 98 | */ |
---|
| 99 | |
---|
| 100 | const char *errorStr = dlerror(); |
---|
| 101 | |
---|
| 102 | Tcl_AppendResult(interp, "couldn't load file \"", |
---|
| 103 | Tcl_GetString(pathPtr), "\": ", errorStr, NULL); |
---|
| 104 | return TCL_ERROR; |
---|
| 105 | } |
---|
| 106 | |
---|
| 107 | *unloadProcPtr = &TclpUnloadFile; |
---|
| 108 | *loadHandle = (Tcl_LoadHandle) handle; |
---|
| 109 | return TCL_OK; |
---|
| 110 | } |
---|
| 111 | |
---|
| 112 | /* |
---|
| 113 | *---------------------------------------------------------------------- |
---|
| 114 | * |
---|
| 115 | * TclpFindSymbol -- |
---|
| 116 | * |
---|
| 117 | * Looks up a symbol, by name, through a handle associated with a |
---|
| 118 | * previously loaded piece of code (shared library). |
---|
| 119 | * |
---|
| 120 | * Results: |
---|
| 121 | * Returns a pointer to the function associated with 'symbol' if it is |
---|
| 122 | * found. Otherwise returns NULL and may leave an error message in the |
---|
| 123 | * interp's result. |
---|
| 124 | * |
---|
| 125 | *---------------------------------------------------------------------- |
---|
| 126 | */ |
---|
| 127 | |
---|
| 128 | Tcl_PackageInitProc * |
---|
| 129 | TclpFindSymbol( |
---|
| 130 | Tcl_Interp *interp, /* Place to put error messages. */ |
---|
| 131 | Tcl_LoadHandle loadHandle, /* Value from TcpDlopen(). */ |
---|
| 132 | CONST char *symbol) /* Symbol to look up. */ |
---|
| 133 | { |
---|
| 134 | CONST char *native; |
---|
| 135 | Tcl_DString newName, ds; |
---|
| 136 | VOID *handle = (VOID*)loadHandle; |
---|
| 137 | Tcl_PackageInitProc *proc; |
---|
| 138 | |
---|
| 139 | /* |
---|
| 140 | * Some platforms still add an underscore to the beginning of symbol |
---|
| 141 | * names. If we can't find a name without an underscore, try again with |
---|
| 142 | * the underscore. |
---|
| 143 | */ |
---|
| 144 | |
---|
| 145 | native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); |
---|
| 146 | proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ |
---|
| 147 | native); |
---|
| 148 | if (proc == NULL) { |
---|
| 149 | Tcl_DStringInit(&newName); |
---|
| 150 | Tcl_DStringAppend(&newName, "_", 1); |
---|
| 151 | native = Tcl_DStringAppend(&newName, native, -1); |
---|
| 152 | proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */ |
---|
| 153 | native); |
---|
| 154 | Tcl_DStringFree(&newName); |
---|
| 155 | } |
---|
| 156 | Tcl_DStringFree(&ds); |
---|
| 157 | |
---|
| 158 | return proc; |
---|
| 159 | } |
---|
| 160 | |
---|
| 161 | /* |
---|
| 162 | *---------------------------------------------------------------------- |
---|
| 163 | * |
---|
| 164 | * TclpUnloadFile -- |
---|
| 165 | * |
---|
| 166 | * Unloads a dynamically loaded binary code file from memory. Code |
---|
| 167 | * pointers in the formerly loaded file are no longer valid after calling |
---|
| 168 | * this function. |
---|
| 169 | * |
---|
| 170 | * Results: |
---|
| 171 | * None. |
---|
| 172 | * |
---|
| 173 | * Side effects: |
---|
| 174 | * Code removed from memory. |
---|
| 175 | * |
---|
| 176 | *---------------------------------------------------------------------- |
---|
| 177 | */ |
---|
| 178 | |
---|
| 179 | void |
---|
| 180 | TclpUnloadFile( |
---|
| 181 | Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to |
---|
| 182 | * TclpDlopen(). The loadHandle is a token |
---|
| 183 | * that represents the loaded file. */ |
---|
| 184 | { |
---|
| 185 | void *handle; |
---|
| 186 | |
---|
| 187 | handle = (void *) loadHandle; |
---|
| 188 | dlclose(handle); |
---|
| 189 | } |
---|
| 190 | |
---|
| 191 | /* |
---|
| 192 | *---------------------------------------------------------------------- |
---|
| 193 | * |
---|
| 194 | * TclGuessPackageName -- |
---|
| 195 | * |
---|
| 196 | * If the "load" command is invoked without providing a package name, |
---|
| 197 | * this procedure is invoked to try to figure it out. |
---|
| 198 | * |
---|
| 199 | * Results: |
---|
| 200 | * Always returns 0 to indicate that we couldn't figure out a package |
---|
| 201 | * name; generic code will then try to guess the package from the file |
---|
| 202 | * name. A return value of 1 would have meant that we figured out the |
---|
| 203 | * package name and put it in bufPtr. |
---|
| 204 | * |
---|
| 205 | * Side effects: |
---|
| 206 | * None. |
---|
| 207 | * |
---|
| 208 | *---------------------------------------------------------------------- |
---|
| 209 | */ |
---|
| 210 | |
---|
| 211 | int |
---|
| 212 | TclGuessPackageName( |
---|
| 213 | CONST char *fileName, /* Name of file containing package (already |
---|
| 214 | * translated to local form if needed). */ |
---|
| 215 | Tcl_DString *bufPtr) /* Initialized empty dstring. Append package |
---|
| 216 | * name to this if possible. */ |
---|
| 217 | { |
---|
| 218 | return 0; |
---|
| 219 | } |
---|
| 220 | |
---|
| 221 | /* |
---|
| 222 | * Local Variables: |
---|
| 223 | * mode: c |
---|
| 224 | * c-basic-offset: 4 |
---|
| 225 | * fill-column: 78 |
---|
| 226 | * End: |
---|
| 227 | */ |
---|