This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make die/warn and other diagnostics go to wherever STDERR happens
[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 (pmarquess@bfsec.bt.co.uk)
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  *
14  */
15
16 /* Porting notes:
17
18
19    Definition of Sunos dynamic Linking functions
20    =============================================
21    In order to make this implementation easier to understand here is a
22    quick definition of the SunOS Dynamic Linking functions which are
23    used here.
24
25    dlopen
26    ------
27      void *
28      dlopen(path, mode)
29      char * path; 
30      int    mode;
31
32      This function takes the name of a dynamic object file and returns
33      a descriptor which can be used by dlsym later. It returns NULL on
34      error.
35
36      The mode parameter must be set to 1 for Solaris 1 and to
37      RTLD_LAZY (==2) on Solaris 2.
38
39
40    dlsym
41    ------
42      void *
43      dlsym(handle, symbol)
44      void * handle; 
45      char * symbol;
46
47      Takes the handle returned from dlopen and the name of a symbol to
48      get the address of. If the symbol was found a pointer is
49      returned.  It returns NULL on error. If DL_PREPEND_UNDERSCORE is
50      defined an underscore will be added to the start of symbol. This
51      is required on some platforms (freebsd).
52
53    dlerror
54    ------
55      char * dlerror()
56
57      Returns a null-terminated string which describes the last error
58      that occurred with either dlopen or dlsym. After each call to
59      dlerror the error message will be reset to a null pointer. The
60      SaveError function is used to save the error as soo as it happens.
61
62
63    Return Types
64    ============
65    In this implementation the two functions, dl_load_file &
66    dl_find_symbol, return void *. This is because the underlying SunOS
67    dynamic linker calls also return void *.  This is not necessarily
68    the case for all architectures. For example, some implementation
69    will want to return a char * for dl_load_file.
70
71    If void * is not appropriate for your architecture, you will have to
72    change the void * to whatever you require. If you are not certain of
73    how Perl handles C data types, I suggest you start by consulting     
74    Dean Roerich's Perl 5 API document. Also, have a look in the typemap 
75    file (in the ext directory) for a fairly comprehensive list of types 
76    that are already supported. If you are completely stuck, I suggest you
77    post a message to perl5-porters, comp.lang.perl.misc or if you are really 
78    desperate to me.
79
80    Remember when you are making any changes that the return value from 
81    dl_load_file is used as a parameter in the dl_find_symbol 
82    function. Also the return value from find_symbol is used as a parameter 
83    to install_xsub.
84
85
86    Dealing with Error Messages
87    ============================
88    In order to make the handling of dynamic linking errors as generic as
89    possible you should store any error messages associated with your
90    implementation with the StoreError function.
91
92    In the case of SunOS the function dlerror returns the error message 
93    associated with the last dynamic link error. As the SunOS dynamic 
94    linker functions dlopen & dlsym both return NULL on error every call 
95    to a SunOS dynamic link routine is coded like this
96
97         RETVAL = dlopen(filename, 1) ;
98         if (RETVAL == NULL)
99             SaveError("%s",dlerror()) ;
100
101    Note that SaveError() takes a printf format string. Use a "%s" as
102    the first parameter if the error may contain and % characters.
103
104 */
105
106 #include "EXTERN.h"
107 #include "perl.h"
108 #include "XSUB.h"
109
110 #ifdef I_DLFCN
111 #include <dlfcn.h>      /* the dynamic linker include file for Sunos/Solaris */
112 #else
113 #include <nlist.h>
114 #include <link.h>
115 #endif
116
117 #ifndef RTLD_LAZY
118 # define RTLD_LAZY 1    /* Solaris 1 */
119 #endif
120
121 #ifndef HAS_DLERROR
122 # ifdef __NetBSD__
123 #  define dlerror() strerror(errno)
124 # else
125 #  define dlerror() "Unknown error - dlerror() not implemented"
126 # endif
127 #endif
128
129
130 #include "dlutils.c"    /* SaveError() etc      */
131
132
133 static void
134 dl_private_init(pTHX)
135 {
136     (void)dl_generic_private_init(aTHX);
137 }
138
139 MODULE = DynaLoader     PACKAGE = DynaLoader
140
141 BOOT:
142     (void)dl_private_init(aTHX);
143
144
145 void *
146 dl_load_file(filename, flags=0)
147     char *      filename
148     int         flags
149     PREINIT:
150     int mode = RTLD_LAZY;
151     CODE:
152 #ifdef RTLD_NOW
153     if (dl_nonlazy)
154         mode = RTLD_NOW;
155 #endif
156     if (flags & 0x01)
157 #ifdef RTLD_GLOBAL
158         mode |= RTLD_GLOBAL;
159 #else
160         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
161 #endif
162     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
163     RETVAL = dlopen(filename, mode) ;
164     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL));
165     ST(0) = sv_newmortal() ;
166     if (RETVAL == NULL)
167         SaveError(aTHX_ "%s",dlerror()) ;
168     else
169         sv_setiv( ST(0), PTR2IV(RETVAL));
170
171
172 void *
173 dl_find_symbol(libhandle, symbolname)
174     void *      libhandle
175     char *      symbolname
176     CODE:
177 #ifdef DLSYM_NEEDS_UNDERSCORE
178     symbolname = form("_%s", symbolname);
179 #endif
180     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
181                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
182                              (unsigned long) libhandle, symbolname));
183     RETVAL = dlsym(libhandle, symbolname);
184     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
185                              "  symbolref = %lx\n", (unsigned long) RETVAL));
186     ST(0) = sv_newmortal() ;
187     if (RETVAL == NULL)
188         SaveError(aTHX_ "%s",dlerror()) ;
189     else
190         sv_setiv( ST(0), PTR2IV(RETVAL));
191
192
193 void
194 dl_undef_symbols()
195     PPCODE:
196
197
198
199 # These functions should not need changing on any platform:
200
201 void
202 dl_install_xsub(perl_name, symref, filename="$Package")
203     char *              perl_name
204     void *              symref 
205     char *              filename
206     CODE:
207     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n",
208                 perl_name, (unsigned long) symref));
209     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
210                                         (void(*)(pTHX_ CV *))symref,
211                                         filename)));
212
213
214 char *
215 dl_error()
216     CODE:
217     RETVAL = LastError ;
218     OUTPUT:
219     RETVAL
220
221 # end.