This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix bug in DynaLoader, which has been passing a filename in dynamic
[perl5.git] / ext / DynaLoader / dl_dlopen.xs
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
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=%"UVxf")\n",
252                 perl_name, PTR2UV(symref)));
253     ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
254                                               DPTR2FPTR(XSUBADDR_t, symref),
255                                               filename, NULL,
256                                               XS_DYNAMIC_FILENAME)));
257
258
259 char *
260 dl_error()
261     CODE:
262     dMY_CXT;
263     RETVAL = dl_last_error ;
264     OUTPUT:
265     RETVAL
266
267 # end.