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
10 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11 */
12
13 #include "tclInt.h"
14 #ifdef NO_DLFCN_H
15 # include "../compat/dlfcn.h"
16 #else
17 # include <dlfcn.h>
18 #endif
19
20 /*
21 * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined and this
22 * argument to dlopen must always be 1. The RTLD_LOCAL flag doesn't exist on
23 * some platforms; if it doesn't exist, set it to 0 so it has no effect.
24 * See [Bug #3216070]
25 */
26
27 #ifndef RTLD_NOW
28 # define RTLD_NOW 1
29 #endif
30
31 #ifndef RTLD_LOCAL
32 # define RTLD_LOCAL 0
33 #endif
34
35 /*
36 * Static procedures defined within this file.
37 */
38
39 static void * FindSymbol(Tcl_Interp *interp,
40 Tcl_LoadHandle loadHandle, const char *symbol);
41 static void UnloadFile(Tcl_LoadHandle loadHandle);
42
43 /*
44 *---------------------------------------------------------------------------
45 *
46 * TclpDlopen --
47 *
48 * Dynamically loads a binary code file into memory and returns a handle
49 * to the new code.
50 *
51 * Results:
52 * A standard Tcl completion code. If an error occurs, an error message
53 * is left in the interp's result.
54 *
55 * Side effects:
56 * New code suddenly appears in memory.
57 *
58 *---------------------------------------------------------------------------
59 */
60
61 int
TclpDlopen(Tcl_Interp * interp,Tcl_Obj * pathPtr,Tcl_LoadHandle * loadHandle,Tcl_FSUnloadFileProc ** unloadProcPtr,int flags)62 TclpDlopen(
63 Tcl_Interp *interp, /* Used for error reporting. */
64 Tcl_Obj *pathPtr, /* Name of the file containing the desired
65 * code (UTF-8). */
66 Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
67 * file which will be passed back to
68 * (*unloadProcPtr)() to unload the file. */
69 Tcl_FSUnloadFileProc **unloadProcPtr,
70 /* Filled with address of Tcl_FSUnloadFileProc
71 * function which should be used for this
72 * file. */
73 int flags)
74 {
75 void *handle;
76 Tcl_LoadHandle newHandle;
77 const char *native;
78 int dlopenflags = 0;
79
80 /*
81 * First try the full path the user gave us. This is particularly
82 * important if the cwd is inside a vfs, and we are trying to load using a
83 * relative path.
84 */
85
86 native = Tcl_FSGetNativePath(pathPtr);
87 /*
88 * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
89 */
90 if (flags & TCL_LOAD_GLOBAL) {
91 dlopenflags |= RTLD_GLOBAL;
92 } else {
93 dlopenflags |= RTLD_LOCAL;
94 }
95 if (flags & TCL_LOAD_LAZY) {
96 dlopenflags |= RTLD_LAZY;
97 } else {
98 dlopenflags |= RTLD_NOW;
99 }
100 handle = dlopen(native, dlopenflags);
101 if (handle == NULL) {
102 /*
103 * Let the OS loader examine the binary search path for whatever
104 * string the user gave us which hopefully refers to a file on the
105 * binary path.
106 */
107
108 Tcl_DString ds;
109 const char *fileName = Tcl_GetString(pathPtr);
110
111 native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
112 /*
113 * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
114 */
115 handle = dlopen(native, dlopenflags);
116 Tcl_DStringFree(&ds);
117 }
118
119 if (handle == NULL) {
120 /*
121 * Write the string to a variable first to work around a compiler bug
122 * in the Sun Forte 6 compiler. [Bug 1503729]
123 */
124
125 const char *errorStr = dlerror();
126
127 if (interp) {
128 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
129 "couldn't load file \"%s\": %s",
130 Tcl_GetString(pathPtr), errorStr));
131 }
132 return TCL_ERROR;
133 }
134 newHandle = ckalloc(sizeof(*newHandle));
135 newHandle->clientData = handle;
136 newHandle->findSymbolProcPtr = &FindSymbol;
137 newHandle->unloadFileProcPtr = &UnloadFile;
138 *unloadProcPtr = &UnloadFile;
139 *loadHandle = newHandle;
140
141 return TCL_OK;
142 }
143
144 /*
145 *----------------------------------------------------------------------
146 *
147 * FindSymbol --
148 *
149 * Looks up a symbol, by name, through a handle associated with a
150 * previously loaded piece of code (shared library).
151 *
152 * Results:
153 * Returns a pointer to the function associated with 'symbol' if it is
154 * found. Otherwise returns NULL and may leave an error message in the
155 * interp's result.
156 *
157 *----------------------------------------------------------------------
158 */
159
160 static void *
FindSymbol(Tcl_Interp * interp,Tcl_LoadHandle loadHandle,const char * symbol)161 FindSymbol(
162 Tcl_Interp *interp, /* Place to put error messages. */
163 Tcl_LoadHandle loadHandle, /* Value from TcpDlopen(). */
164 const char *symbol) /* Symbol to look up. */
165 {
166 const char *native; /* Name of the library to be loaded, in
167 * system encoding */
168 Tcl_DString newName, ds; /* Buffers for converting the name to
169 * system encoding and prepending an
170 * underscore*/
171 void *handle = (void *) loadHandle->clientData;
172 /* Native handle to the loaded library */
173 void *proc; /* Address corresponding to the resolved
174 * symbol */
175
176 /*
177 * Some platforms still add an underscore to the beginning of symbol
178 * names. If we can't find a name without an underscore, try again with
179 * the underscore.
180 */
181
182 native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
183 proc = dlsym(handle, native); /* INTL: Native. */
184 if (proc == NULL) {
185 Tcl_DStringInit(&newName);
186 TclDStringAppendLiteral(&newName, "_");
187 native = Tcl_DStringAppend(&newName, native, -1);
188 proc = dlsym(handle, native); /* INTL: Native. */
189 Tcl_DStringFree(&newName);
190 }
191 Tcl_DStringFree(&ds);
192 if (proc == NULL) {
193 const char *errorStr = dlerror();
194
195 if (interp) {
196 if (!errorStr) {
197 errorStr = "unknown";
198 }
199 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
200 "cannot find symbol \"%s\": %s", symbol, errorStr));
201 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
202 NULL);
203 }
204 }
205 return proc;
206 }
207
208 /*
209 *----------------------------------------------------------------------
210 *
211 * UnloadFile --
212 *
213 * Unloads a dynamically loaded binary code file from memory. Code
214 * pointers in the formerly loaded file are no longer valid after calling
215 * this function.
216 *
217 * Results:
218 * None.
219 *
220 * Side effects:
221 * Code removed from memory.
222 *
223 *----------------------------------------------------------------------
224 */
225
226 static void
UnloadFile(Tcl_LoadHandle loadHandle)227 UnloadFile(
228 Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
229 * TclpDlopen(). The loadHandle is a token
230 * that represents the loaded file. */
231 {
232 void *handle = loadHandle->clientData;
233
234 dlclose(handle);
235 ckfree(loadHandle);
236 }
237
238 /*
239 *----------------------------------------------------------------------
240 *
241 * TclGuessPackageName --
242 *
243 * If the "load" command is invoked without providing a package name,
244 * this procedure is invoked to try to figure it out.
245 *
246 * Results:
247 * Always returns 0 to indicate that we couldn't figure out a package
248 * name; generic code will then try to guess the package from the file
249 * name. A return value of 1 would have meant that we figured out the
250 * package name and put it in bufPtr.
251 *
252 * Side effects:
253 * None.
254 *
255 *----------------------------------------------------------------------
256 */
257
258 int
TclGuessPackageName(const char * fileName,Tcl_DString * bufPtr)259 TclGuessPackageName(
260 const char *fileName, /* Name of file containing package (already
261 * translated to local form if needed). */
262 Tcl_DString *bufPtr) /* Initialized empty dstring. Append package
263 * name to this if possible. */
264 {
265 return 0;
266 }
267
268 /*
269 * Local Variables:
270 * mode: c
271 * c-basic-offset: 4
272 * fill-column: 78
273 * End:
274 */
275