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
146static void
147dl_private_init(pTHX)
148{
149    (void)dl_generic_private_init(aTHX);
150}
151
152MODULE = DynaLoader	PACKAGE = DynaLoader
153
154BOOT:
155    (void)dl_private_init(aTHX);
156
157
158void
159dl_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
201int
202dl_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
214void
215dl_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
237void
238dl_undef_symbols()
239    CODE:
240
241
242
243# These functions should not need changing on any platform:
244
245void
246dl_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
258char *
259dl_error()
260    CODE:
261    dMY_CXT;
262    RETVAL = dl_last_error ;
263    OUTPUT:
264    RETVAL
265
266# end.
267