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
CommitLineData
a0d0e21e
LW
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
19dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess. It
20should not be used as a base for further ports though it may be used
21as an example for how dl_dlopen.xs can be ported to other platforms.
22
23The method used here is just to supply the sun style dlopen etc.
24functions in terms of NeXTs rld_*. The xs code proper is unchanged
25from Paul's original.
26
27The port could use some streamlining. For one, error handling could
28be simplified.
29
30Anno Siegel
31
32*/
33
d6bcbf1c
PP
34#if NS_TARGET_MAJOR >= 4
35#else
8e07c86e
AD
36/* include these before perl headers */
37#include <mach-o/rld.h>
38#include <streams/streams.h>
d6bcbf1c 39#endif
8e07c86e 40
a0d0e21e
LW
41#include "EXTERN.h"
42#include "perl.h"
43#include "XSUB.h"
44
8e07c86e 45#define DL_LOADONCEONLY
a0d0e21e 46
cdc73a10
JH
47typedef struct {
48 AV * x_resolve_using;
49} my_cxtx_t; /* this *must* be named my_cxtx_t */
a0d0e21e 50
cdc73a10
JH
51#define DL_CXT_EXTRA /* ask for dl_cxtx to be defined in dlutils.c */
52#include "dlutils.c" /* SaveError() etc */
a0d0e21e 53
cdc73a10 54#define dl_resolve_using (dl_cxtx.x_resolve_using)
a0d0e21e 55
d6bcbf1c
PP
56static char *dlerror()
57{
cdc73a10
JH
58 dTHX;
59 dMY_CXT;
d6bcbf1c
PP
60 return dl_last_error;
61}
62
63int dlclose(handle) /* stub only */
64void *handle;
65{
66 return 0;
67}
68
69#if NS_TARGET_MAJOR >= 4
70#import <mach-o/dyld.h>
71
72enum dyldErrorSource
73{
74 OFImage,
75};
76
77static void TranslateError
78 (const char *path, enum dyldErrorSource type, int number)
79{
5b877257 80 dTHX;
cdc73a10 81 dMY_CXT;
46fc3d4c 82 char *error;
d6bcbf1c
PP
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",
d1be9408 88 "%s(%d): Not a recognisable object file\n",
d6bcbf1c
PP
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
d6bcbf1c
PP
96 switch (type)
97 {
98 case OFImage:
99 index = number;
100 if (index > NUM_OFI_ERRORS - 1)
101 index = NUM_OFI_ERRORS - 1;
7a3f2258 102 error = Perl_form_nocontext(OFIErrorStrings[index], path, number);
d6bcbf1c
PP
103 break;
104
105 default:
7a3f2258 106 error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n",
46fc3d4c 107 path, number, type);
d6bcbf1c
PP
108 break;
109 }
8c52afec 110 Safefree(dl_last_error);
46fc3d4c 111 dl_last_error = savepv(error);
d6bcbf1c
PP
112}
113
114static 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
133void *
134dlsym(handle, symbol)
135void *handle;
136char *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
150static NXStream *OpenError(void)
a0d0e21e
LW
151{
152 return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY);
153}
154
d6bcbf1c 155static void TransferError(NXStream *s)
a0d0e21e
LW
156{
157 char *buffer;
158 int len, maxlen;
ecdc15d9 159 dTHX;
cdc73a10 160 dMY_CXT;
a0d0e21e
LW
161
162 if ( dl_last_error ) {
8c52afec 163 Safefree(dl_last_error);
a0d0e21e
LW
164 }
165 NXGetMemoryBuffer(s, &buffer, &len, &maxlen);
a02a5408 166 Newx(dl_last_error, len, char);
a0d0e21e
LW
167 strcpy(dl_last_error, buffer);
168}
169
d6bcbf1c 170static void CloseError(NXStream *s)
a0d0e21e
LW
171{
172 if ( s ) {
173 NXCloseMemory( s, NX_FREEBUFFER);
174 }
175}
176
d6bcbf1c 177static char *dlopen(char *path, int mode /* mode is ignored */)
a0d0e21e
LW
178{
179 int rld_success;
8e07c86e 180 NXStream *nxerr;
a0d0e21e
LW
181 I32 i, psize;
182 char *result;
183 char **p;
2d8e6c8d 184 STRLEN n_a;
ecdc15d9 185 dTHX;
cdc73a10 186 dMY_CXT;
8e07c86e
AD
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;
a0d0e21e 191
8e07c86e
AD
192 nxerr = OpenError();
193 psize = AvFILL(dl_resolve_using) + 3;
a0d0e21e
LW
194 p = (char **) safemalloc(psize * sizeof(char*));
195 p[0] = path;
196 for(i=1; i<psize-1; i++) {
2d8e6c8d 197 p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a);
a0d0e21e
LW
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;
8e07c86e 205 /* prevent multiple loads of same file into same process */
3280af22 206 hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0);
a0d0e21e
LW
207 } else {
208 TransferError(nxerr);
209 result = (char*) 0;
210 }
211 CloseError(nxerr);
212 return result;
213}
214
a0d0e21e
LW
215void *
216dlsym(handle, symbol)
217void *handle;
218char *symbol;
219{
220 NXStream *nxerr = OpenError();
a0d0e21e
LW
221 unsigned long symref = 0;
222
7a3f2258 223 if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref))
a0d0e21e 224 TransferError(nxerr);
a0d0e21e
LW
225 CloseError(nxerr);
226 return (void*) symref;
227}
228
d6bcbf1c
PP
229#endif /* NS_TARGET_MAJOR >= 4 */
230
a0d0e21e
LW
231
232/* ----- code from dl_dlopen.xs below here ----- */
233
234
235static void
cea2e8a9 236dl_private_init(pTHX)
a0d0e21e 237{
cea2e8a9 238 (void)dl_generic_private_init(aTHX);
cdc73a10
JH
239 {
240 dMY_CXT;
241 dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
242 }
a0d0e21e
LW
243}
244
245MODULE = DynaLoader PACKAGE = DynaLoader
246
247BOOT:
cea2e8a9 248 (void)dl_private_init(aTHX);
a0d0e21e
LW
249
250
251
252void *
ff7f3c60 253dl_load_file(filename, flags=0)
a0d0e21e 254 char * filename
ff7f3c60
NIS
255 int flags
256 PREINIT:
a0d0e21e 257 int mode = 1;
ff7f3c60 258 CODE:
bf49b057 259 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
ff7f3c60 260 if (flags & 0x01)
cea2e8a9 261 Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
a0d0e21e 262 RETVAL = dlopen(filename, mode) ;
bf49b057 263 DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
a0d0e21e
LW
264 ST(0) = sv_newmortal() ;
265 if (RETVAL == NULL)
cea2e8a9 266 SaveError(aTHX_ "%s",dlerror()) ;
a0d0e21e 267 else
3175b8cd 268 sv_setiv( ST(0), PTR2IV(RETVAL) );
a0d0e21e
LW
269
270
271void *
272dl_find_symbol(libhandle, symbolname)
273 void * libhandle
274 char * symbolname
275 CODE:
d6bcbf1c 276#if NS_TARGET_MAJOR >= 4
7a3f2258 277 symbolname = Perl_form_nocontext("_%s", symbolname);
d6bcbf1c 278#endif
bf49b057 279 DLDEBUG(2, PerlIO_printf(Perl_debug_log,
46fc3d4c
PP
280 "dl_find_symbol(handle=%lx, symbol=%s)\n",
281 (unsigned long) libhandle, symbolname));
a0d0e21e 282 RETVAL = dlsym(libhandle, symbolname);
bf49b057 283 DLDEBUG(2, PerlIO_printf(Perl_debug_log,
46fc3d4c 284 " symbolref = %lx\n", (unsigned long) RETVAL));
a0d0e21e
LW
285 ST(0) = sv_newmortal() ;
286 if (RETVAL == NULL)
cea2e8a9 287 SaveError(aTHX_ "%s",dlerror()) ;
a0d0e21e 288 else
3175b8cd 289 sv_setiv( ST(0), PTR2IV(RETVAL) );
a0d0e21e
LW
290
291
292void
293dl_undef_symbols()
294 PPCODE:
295
296
297
298# These functions should not need changing on any platform:
299
300void
301dl_install_xsub(perl_name, symref, filename="$Package")
302 char * perl_name
303 void * symref
304 char * filename
305 CODE:
bf49b057 306 DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
a0d0e21e 307 perl_name, symref));
77004dee
NC
308 ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
309 (void(*)(pTHX_ CV *))symref,
310 filename, NULL,
311 XS_DYNAMIC_FILENAME)));
a0d0e21e
LW
312
313
314char *
315dl_error()
316 CODE:
cdc73a10
JH
317 dMY_CXT;
318 RETVAL = dl_last_error ;
a0d0e21e
LW
319 OUTPUT:
320 RETVAL
321
322# end.