1 /* dl_dlopen.xs
2 *
3 * Platform: SunOS/Solaris, possibly others which use dlopen.
4 * Author: Paul Marquess (Paul.Marquess@btinternet.com)
5 * Created: 10th July 1994
6 *
7 * Modified:
8 * 15th July 1994 - Added code to explicitly save any error messages.
9 * 3rd August 1994 - Upgraded to v3 spec.
10 * 9th August 1994 - Changed to use IV
11 * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging,
12 * basic FreeBSD support, removed ClearError
13 * 29th February 2000 - Alan Burlison: Added functionality to close dlopen'd
14 * files when the interpreter exits
15 * 2015-03-12 - rurban: Added optional 3rd dl_find_symbol argument
16 *
17 */
18
19 /* Porting notes:
20
21
22 Definition of Sunos dynamic Linking functions
23 =============================================
24 In order to make this implementation easier to understand here is a
25 quick definition of the SunOS Dynamic Linking functions which are
26 used here.
27
28 dlopen
29 ------
30 void *
31 dlopen(path, mode)
32 char * path;
33 int mode;
34
35 This function takes the name of a dynamic object file and returns
36 a descriptor which can be used by dlsym later. It returns NULL on
37 error.
38
39 The mode parameter must be set to 1 for Solaris 1 and to
40 RTLD_LAZY (==2) on Solaris 2.
41
42
43 dlclose
44 -------
45 int
46 dlclose(handle)
47 void * handle;
48
49 This function takes the handle returned by a previous invocation of
50 dlopen and closes the associated dynamic object file. It returns zero
51 on success, and non-zero on failure.
52
53
54 dlsym
55 ------
56 void *
57 dlsym(handle, symbol)
58 void * handle;
59 char * symbol;
60
61 Takes the handle returned from dlopen and the name of a symbol to
62 get the address of. If the symbol was found a pointer is
63 returned. It returns NULL on error. If DL_PREPEND_UNDERSCORE is
64 defined an underscore will be added to the start of symbol. This
65 is required on some platforms (freebsd).
66
67 dlerror
68 ------
69 char * dlerror()
70
71 Returns a null-terminated string which describes the last error
72 that occurred with either dlopen or dlsym. After each call to
73 dlerror the error message will be reset to a null pointer. The
74 SaveError function is used to save the error as soon as it happens.
75
76
77 Return Types
78 ============
79 In this implementation the two functions, dl_load_file &
80 dl_find_symbol, return void *. This is because the underlying SunOS
81 dynamic linker calls also return void *. This is not necessarily
82 the case for all architectures. For example, some implementation
83 will want to return a char * for dl_load_file.
84
85 If void * is not appropriate for your architecture, you will have to
86 change the void * to whatever you require. If you are not certain of
87 how Perl handles C data types, I suggest you start by consulting
88 Dean Roerich's Perl 5 API document. Also, have a look in the typemap
89 file (in the ext directory) for a fairly comprehensive list of types
90 that are already supported. If you are completely stuck, I suggest you
91 post a message to perl5-porters.
92
93 Remember when you are making any changes that the return value from
94 dl_load_file is used as a parameter in the dl_find_symbol
95 function. Also the return value from find_symbol is used as a parameter
96 to install_xsub.
97
98
99 Dealing with Error Messages
100 ============================
101 In order to make the handling of dynamic linking errors as generic as
102 possible you should store any error messages associated with your
103 implementation with the StoreError function.
104
105 In the case of SunOS the function dlerror returns the error message
106 associated with the last dynamic link error. As the SunOS dynamic
107 linker functions dlopen & dlsym both return NULL on error every call
108 to a SunOS dynamic link routine is coded like this
109
110 RETVAL = dlopen(filename, 1) ;
111 if (RETVAL == NULL)
112 SaveError("%s",dlerror()) ;
113
114 Note that SaveError() takes a printf format string. Use a "%s" as
115 the first parameter if the error may contain any % characters.
116
117 */
118
119 #define PERL_NO_GET_CONTEXT
120 #define PERL_EXT
121
122 #include "EXTERN.h"
123 #define PERL_IN_DL_DLOPEN_XS
124 #include "perl.h"
125 #include "XSUB.h"
126
127 #ifdef I_DLFCN
128 #include <dlfcn.h> /* the dynamic linker include file for Sunos/Solaris */
129 #else
130 #include <nlist.h>
131 #include <link.h>
132 #endif
133
134 #ifndef RTLD_LAZY
135 # define RTLD_LAZY 1 /* Solaris 1 */
136 #endif
137
138 #ifndef HAS_DLERROR
139 # ifdef __NetBSD__
140 # define dlerror() strerror(errno)
141 # else
142 # define dlerror() "Unknown error - dlerror() not implemented"
143 # endif
144 #endif
145
146
147 #include "dlutils.c" /* SaveError() etc */
148
149
150 static void
dl_private_init(pTHX)151 dl_private_init(pTHX)
152 {
153 (void)dl_generic_private_init(aTHX);
154 }
155
156 MODULE = DynaLoader PACKAGE = DynaLoader
157
158 BOOT:
159 (void)dl_private_init(aTHX);
160
161
162 void
163 dl_load_file(filename, flags=0)
164 char * filename
165 int flags
166 PREINIT:
167 int mode = RTLD_LAZY;
168 void *handle;
169 CODE:
170 {
171 #if defined(DLOPEN_WONT_DO_RELATIVE_PATHS)
172 char pathbuf[PATH_MAX + 2];
173 if (*filename != '/' && strchr(filename, '/')) {
174 const size_t filename_len = strlen(filename);
175 if (getcwd(pathbuf, PATH_MAX - filename_len)) {
176 const size_t path_len = strlen(pathbuf);
177 pathbuf[path_len] = '/';
178 filename = (char *) memcpy(pathbuf + path_len + 1, filename, filename_len + 1);
179 }
180 }
181 #endif
182 #ifdef RTLD_NOW
183 {
184 dMY_CXT;
185 if (dl_nonlazy)
186 mode = RTLD_NOW;
187 }
188 #endif
189 if (flags & 0x01)
190 #ifdef RTLD_GLOBAL
191 mode |= RTLD_GLOBAL;
192 #else
193 Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
194 #endif
195 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
196 handle = dlopen(filename, mode) ;
197 DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) handle));
198 ST(0) = sv_newmortal() ;
199 if (handle == NULL)
200 SaveError(aTHX_ "%s",dlerror()) ;
201 else
202 sv_setiv( ST(0), PTR2IV(handle));
203 }
204
205
206 int
207 dl_unload_file(libref)
208 void * libref
209 CODE:
210 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref)));
211 RETVAL = (dlclose(libref) == 0 ? 1 : 0);
212 if (!RETVAL)
213 SaveError(aTHX_ "%s", dlerror()) ;
214 DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL));
215 OUTPUT:
216 RETVAL
217
218
219 void
220 dl_find_symbol(libhandle, symbolname, ign_err=0)
221 void * libhandle
222 char * symbolname
223 int ign_err
224 PREINIT:
225 void *sym;
226 CODE:
227 #ifdef DLSYM_NEEDS_UNDERSCORE
228 symbolname = Perl_form_nocontext("_%s", symbolname);
229 #endif
230 DLDEBUG(2, PerlIO_printf(Perl_debug_log,
231 "dl_find_symbol(handle=%lx, symbol=%s)\n",
232 (unsigned long) libhandle, symbolname));
233 sym = dlsym(libhandle, symbolname);
234 DLDEBUG(2, PerlIO_printf(Perl_debug_log,
235 " symbolref = %lx\n", (unsigned long) sym));
236 ST(0) = sv_newmortal();
237 if (sym == NULL) {
238 if (!ign_err)
239 SaveError(aTHX_ "%s", dlerror());
240 } else
241 sv_setiv( ST(0), PTR2IV(sym));
242
243
244 void
245 dl_undef_symbols()
246 CODE:
247
248
249
250 # These functions should not need changing on any platform:
251
252 void
253 dl_install_xsub(perl_name, symref, filename="$Package")
254 char * perl_name
255 void * symref
256 const char * filename
257 CODE:
258 DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%" UVxf ")\n",
259 perl_name, PTR2UV(symref)));
260 ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
261 DPTR2FPTR(XSUBADDR_t, symref),
262 filename, NULL,
263 XS_DYNAMIC_FILENAME)));
264
265
266 SV *
267 dl_error()
268 CODE:
269 dMY_CXT;
270 RETVAL = newSVsv(MY_CXT.x_dl_last_error);
271 OUTPUT:
272 RETVAL
273
274 #if defined(USE_ITHREADS)
275
276 void
277 CLONE(...)
278 CODE:
279 MY_CXT_CLONE;
280
281 PERL_UNUSED_VAR(items);
282
283 /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
284 * using Perl variables that belong to another thread, we create our
285 * own for this thread.
286 */
287 MY_CXT.x_dl_last_error = newSVpvs("");
288
289 #endif
290
291 # end.
292