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_next.xs
1 /* dl_next.xs
2  * 
3  * Platform:    NeXT NS 3.2
4  * Author:      Anno Siegel (siegel@zrz.TU-Berlin.DE)
5  * Based on:    dl_dlopen.xs by Paul Marquess
6  * Created:     Aug 15th, 1994
7  *
8  */
9
10 /*
11     And Gandalf said: 'Many folk like to know beforehand what is to
12     be set on the table; but those who have laboured to prepare the
13     feast like to keep their secret; for wonder makes the words of
14     praise louder.'
15 */
16
17 /* Porting notes:
18
19 dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess.  It
20 should not be used as a base for further ports though it may be used
21 as an example for how dl_dlopen.xs can be ported to other platforms.
22
23 The method used here is just to supply the sun style dlopen etc.
24 functions in terms of NeXTs rld_*.  The xs code proper is unchanged
25 from Paul's original.
26
27 The port could use some streamlining.  For one, error handling could
28 be simplified.
29
30 Anno Siegel
31
32 */
33
34 #if NS_TARGET_MAJOR >= 4
35 #else
36 /* include these before perl headers */
37 #include <mach-o/rld.h>
38 #include <streams/streams.h>
39 #endif
40
41 #include "EXTERN.h"
42 #include "perl.h"
43 #include "XSUB.h"
44
45 #define DL_LOADONCEONLY
46
47 typedef struct {
48     AV *        x_resolve_using;
49 } my_cxtx_t;            /* this *must* be named my_cxtx_t */
50
51 #define DL_CXT_EXTRA    /* ask for dl_cxtx to be defined in dlutils.c */
52 #include "dlutils.c"    /* SaveError() etc      */
53
54 #define dl_resolve_using        (dl_cxtx.x_resolve_using)
55
56 static char *dlerror()
57 {
58     dTHX;
59     dMY_CXT;
60     return dl_last_error;
61 }
62
63 int dlclose(handle) /* stub only */
64 void *handle;
65 {
66     return 0;
67 }
68
69 #if NS_TARGET_MAJOR >= 4
70 #import <mach-o/dyld.h>
71
72 enum dyldErrorSource
73 {
74     OFImage,
75 };
76
77 static void TranslateError
78     (const char *path, enum dyldErrorSource type, int number)
79 {
80     dTHX;
81     dMY_CXT;
82     char *error;
83     unsigned int index;
84     static char *OFIErrorStrings[] =
85     {
86         "%s(%d): Object Image Load Failure\n",
87         "%s(%d): Object Image Load Success\n",
88         "%s(%d): Not a recognisable object file\n",
89         "%s(%d): No valid architecture\n",
90         "%s(%d): Object image has an invalid format\n",
91         "%s(%d): Invalid access (permissions?)\n",
92         "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
93     };
94 #define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
95
96     switch (type)
97     {
98     case OFImage:
99         index = number;
100         if (index > NUM_OFI_ERRORS - 1)
101             index = NUM_OFI_ERRORS - 1;
102         error = Perl_form_nocontext(OFIErrorStrings[index], path, number);
103         break;
104
105     default:
106         error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n",
107                      path, number, type);
108         break;
109     }
110     Safefree(dl_last_error);
111     dl_last_error = savepv(error);
112 }
113
114 static char *dlopen(char *path, int mode /* mode is ignored */)
115 {
116     int dyld_result;
117     NSObjectFileImage ofile;
118     NSModule handle = NULL;
119
120     dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
121     if (dyld_result != NSObjectFileImageSuccess)
122         TranslateError(path, OFImage, dyld_result);
123     else
124     {
125         // NSLinkModule will cause the run to abort on any link error's
126         // not very friendly but the error recovery functionality is limited.
127         handle = NSLinkModule(ofile, path, TRUE);
128     }
129     
130     return handle;
131 }
132
133 void *
134 dlsym(handle, symbol)
135 void *handle;
136 char *symbol;
137 {
138     void *addr;
139
140     if (NSIsSymbolNameDefined(symbol))
141         addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
142     else
143         addr = NULL;
144
145     return addr;
146 }
147
148 #else /* NS_TARGET_MAJOR <= 3 */
149
150 static NXStream *OpenError(void)
151 {
152     return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY);
153 }
154
155 static void TransferError(NXStream *s)
156 {
157     char *buffer;
158     int len, maxlen;
159     dTHX;
160     dMY_CXT;
161
162     if ( dl_last_error ) {
163         Safefree(dl_last_error);
164     }
165     NXGetMemoryBuffer(s, &buffer, &len, &maxlen);
166     Newx(dl_last_error, len, char);
167     strcpy(dl_last_error, buffer);
168 }
169
170 static void CloseError(NXStream *s)
171 {
172     if ( s ) {
173       NXCloseMemory( s, NX_FREEBUFFER);
174     }
175 }
176
177 static char *dlopen(char *path, int mode /* mode is ignored */)
178 {
179     int rld_success;
180     NXStream *nxerr;
181     I32 i, psize;
182     char *result;
183     char **p;
184     STRLEN n_a;
185     dTHX;
186     dMY_CXT;
187         
188     /* Do not load what is already loaded into this process */
189     if (hv_fetch(dl_loaded_files, path, strlen(path), 0))
190         return path;
191
192     nxerr = OpenError();
193     psize = AvFILL(dl_resolve_using) + 3;
194     p = (char **) safemalloc(psize * sizeof(char*));
195     p[0] = path;
196     for(i=1; i<psize-1; i++) {
197         p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a);
198     }
199     p[psize-1] = 0;
200     rld_success = rld_load(nxerr, (struct mach_header **)0, p,
201                             (const char *) 0);
202     safefree((char*) p);
203     if (rld_success) {
204         result = path;
205         /* prevent multiple loads of same file into same process */
206         hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0);
207     } else {
208         TransferError(nxerr);
209         result = (char*) 0;
210     }
211     CloseError(nxerr);
212     return result;
213 }
214
215 void *
216 dlsym(handle, symbol)
217 void *handle;
218 char *symbol;
219 {
220     NXStream    *nxerr = OpenError();
221     unsigned long       symref = 0;
222
223     if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref))
224         TransferError(nxerr);
225     CloseError(nxerr);
226     return (void*) symref;
227 }
228
229 #endif /* NS_TARGET_MAJOR >= 4 */
230
231
232 /* ----- code from dl_dlopen.xs below here ----- */
233
234
235 static void
236 dl_private_init(pTHX)
237 {
238     (void)dl_generic_private_init(aTHX);
239     {
240         dMY_CXT;
241         dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
242     }
243 }
244  
245 MODULE = DynaLoader     PACKAGE = DynaLoader
246
247 BOOT:
248     (void)dl_private_init(aTHX);
249
250
251
252 void *
253 dl_load_file(filename, flags=0)
254     char *      filename
255     int         flags
256     PREINIT:
257     int mode = 1;
258     CODE:
259     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
260     if (flags & 0x01)
261         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
262     RETVAL = dlopen(filename, mode) ;
263     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
264     ST(0) = sv_newmortal() ;
265     if (RETVAL == NULL)
266         SaveError(aTHX_ "%s",dlerror()) ;
267     else
268         sv_setiv( ST(0), PTR2IV(RETVAL) );
269
270
271 void *
272 dl_find_symbol(libhandle, symbolname)
273     void *              libhandle
274     char *              symbolname
275     CODE:
276 #if NS_TARGET_MAJOR >= 4
277     symbolname = Perl_form_nocontext("_%s", symbolname);
278 #endif
279     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
280                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
281                              (unsigned long) libhandle, symbolname));
282     RETVAL = dlsym(libhandle, symbolname);
283     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
284                              "  symbolref = %lx\n", (unsigned long) RETVAL));
285     ST(0) = sv_newmortal() ;
286     if (RETVAL == NULL)
287         SaveError(aTHX_ "%s",dlerror()) ;
288     else
289         sv_setiv( ST(0), PTR2IV(RETVAL) );
290
291
292 void
293 dl_undef_symbols()
294     PPCODE:
295
296
297
298 # These functions should not need changing on any platform:
299
300 void
301 dl_install_xsub(perl_name, symref, filename="$Package")
302     char *      perl_name
303     void *      symref 
304     char *      filename
305     CODE:
306     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
307             perl_name, symref));
308     ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
309                                               (void(*)(pTHX_ CV *))symref,
310                                               filename, NULL,
311                                               XS_DYNAMIC_FILENAME)));
312
313
314 char *
315 dl_error()
316     CODE:
317     dMY_CXT;
318     RETVAL = dl_last_error ;
319     OUTPUT:
320     RETVAL
321
322 # end.