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 | */ |
---|