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 Feburary 2000 - Alan Burlison: Added functionality to close dlopen'd
14 * files when the interpreter exits
15 *
16 */
17
18 /* Porting notes:
19
20
21 Definition of Sunos dynamic Linking functions
22 =============================================
23 In order to make this implementation easier to understand here is a
24 quick definition of the SunOS Dynamic Linking functions which are
25 used here.
26
27 dlopen
28 ------
29 void *
30 dlopen(path, mode)
31 char * path;
32 int mode;
33
34 This function takes the name of a dynamic object file and returns
35 a descriptor which can be used by dlsym later. It returns NULL on
36 error.
37
38 The mode parameter must be set to 1 for Solaris 1 and to
39 RTLD_LAZY (==2) on Solaris 2.
40
41
42 dlclose
43 -------
44 int
45 dlclose(handle)
46 void * handle;
47
48 This function takes the handle returned by a previous invocation of
49 dlopen and closes the associated dynamic object file. It returns zero
50 on success, and non-zero on failure.
51
52
53 dlsym
54 ------
55 void *
56 dlsym(handle, symbol)
57 void * handle;
58 char * symbol;
59
60 Takes the handle returned from dlopen and the name of a symbol to
61 get the address of. If the symbol was found a pointer is
62 returned. It returns NULL on error. If DL_PREPEND_UNDERSCORE is
63 defined an underscore will be added to the start of symbol. This
64 is required on some platforms (freebsd).
65
66 dlerror
67 ------
68 char * dlerror()
69
70 Returns a null-terminated string which describes the last error
71 that occurred with either dlopen or dlsym. After each call to
72 dlerror the error message will be reset to a null pointer. The
73 SaveError function is used to save the error as soon as it happens.
74
75
76 Return Types
77 ============
78 In this implementation the two functions, dl_load_file &
79 dl_find_symbol, return void *. This is because the underlying SunOS
80 dynamic linker calls also return void *. This is not necessarily
81 the case for all architectures. For example, some implementation
82 will want to return a char * for dl_load_file.
83
84 If void * is not appropriate for your architecture, you will have to
85 change the void * to whatever you require. If you are not certain of
86 how Perl handles C data types, I suggest you start by consulting
87 Dean Roerich's Perl 5 API document. Also, have a look in the typemap
88 file (in the ext directory) for a fairly comprehensive list of types
89 that are already supported. If you are completely stuck, I suggest you
90 post a message to perl5-porters, comp.lang.perl.misc or if you are really
91 desperate to me.
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 #include "EXTERN.h"
120 #include "perl.h"
121 #include "XSUB.h"
122
123 #ifdef I_DLFCN
124 #include <dlfcn.h> /* the dynamic linker include file for Sunos/Solaris */
125 #else
126 #include <nlist.h>
127 #include <link.h>
128 #endif
129
130 #ifndef RTLD_LAZY
131 # define RTLD_LAZY 1 /* Solaris 1 */
132 #endif
133
134 #ifndef HAS_DLERROR
135 # ifdef __NetBSD__
136 # define dlerror() strerror(errno)
137 # else
138 # define dlerror() "Unknown error - dlerror() not implemented"
139 # endif
140 #endif
141
142
143 #include "dlutils.c" /* SaveError() etc */
144
145
146 static void
dl_private_init(pTHX)147 dl_private_init(pTHX)
148 {
149 (void)dl_generic_private_init(aTHX);
150 }
151
152 MODULE = DynaLoader PACKAGE = DynaLoader
153
154 BOOT:
155 (void)dl_private_init(aTHX);
156
157
158 void
159 dl_load_file(filename, flags=0)
160 char * filename
161 int flags
162 PREINIT:
163 int mode = RTLD_LAZY;
164 void *handle;
165 CODE:
166 {
167 #if defined(DLOPEN_WONT_DO_RELATIVE_PATHS)
168 char pathbuf[PATH_MAX + 2];
169 if (*filename != '/' && strchr(filename, '/')) {
170 if (getcwd(pathbuf, PATH_MAX - strlen(filename))) {
171 strcat(pathbuf, "/");
172 strcat(pathbuf, filename);
173 filename = pathbuf;
174 }
175 }
176 #endif
177 #ifdef RTLD_NOW
178 {
179 dMY_CXT;
180 if (dl_nonlazy)
181 mode = RTLD_NOW;
182 }
183 #endif
184 if (flags & 0x01)
185 #ifdef RTLD_GLOBAL
186 mode |= RTLD_GLOBAL;
187 #else
188 Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
189 #endif
190 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
191 handle = dlopen(filename, mode) ;
192 DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) handle));
193 ST(0) = sv_newmortal() ;
194 if (handle == NULL)
195 SaveError(aTHX_ "%s",dlerror()) ;
196 else
197 sv_setiv( ST(0), PTR2IV(handle));
198 }
199
200
201 int
202 dl_unload_file(libref)
203 void * libref
204 CODE:
205 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref)));
206 RETVAL = (dlclose(libref) == 0 ? 1 : 0);
207 if (!RETVAL)
208 SaveError(aTHX_ "%s", dlerror()) ;
209 DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL));
210 OUTPUT:
211 RETVAL
212
213
214 void
215 dl_find_symbol(libhandle, symbolname)
216 void * libhandle
217 char * symbolname
218 PREINIT:
219 void *sym;
220 CODE:
221 #ifdef DLSYM_NEEDS_UNDERSCORE
222 symbolname = Perl_form_nocontext("_%s", symbolname);
223 #endif
224 DLDEBUG(2, PerlIO_printf(Perl_debug_log,
225 "dl_find_symbol(handle=%lx, symbol=%s)\n",
226 (unsigned long) libhandle, symbolname));
227 sym = dlsym(libhandle, symbolname);
228 DLDEBUG(2, PerlIO_printf(Perl_debug_log,
229 " symbolref = %lx\n", (unsigned long) sym));
230 ST(0) = sv_newmortal() ;
231 if (sym == NULL)
232 SaveError(aTHX_ "%s",dlerror()) ;
233 else
234 sv_setiv( ST(0), PTR2IV(sym));
235
236
237 void
238 dl_undef_symbols()
239 CODE:
240
241
242
243 # These functions should not need changing on any platform:
244
245 void
246 dl_install_xsub(perl_name, symref, filename="$Package")
247 char * perl_name
248 void * symref
249 char * filename
250 CODE:
251 DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n",
252 perl_name, (unsigned long) symref));
253 ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
254 (void(*)(pTHX_ CV *))symref,
255 filename)));
256
257
258 char *
259 dl_error()
260 CODE:
261 dMY_CXT;
262 RETVAL = dl_last_error ;
263 OUTPUT:
264 RETVAL
265
266 # end.
267