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_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 #include "dlutils.c"    /* SaveError() etc      */
48
49
50 static char * dl_last_error = (char *) 0;
51 static AV *dl_resolve_using = Nullav;
52
53 static char *dlerror()
54 {
55     return dl_last_error;
56 }
57
58 int dlclose(handle) /* stub only */
59 void *handle;
60 {
61     return 0;
62 }
63
64 #if NS_TARGET_MAJOR >= 4
65 #import <mach-o/dyld.h>
66
67 enum dyldErrorSource
68 {
69     OFImage,
70 };
71
72 static void TranslateError
73     (const char *path, enum dyldErrorSource type, int number)
74 {
75     dTHX;
76     char *error;
77     unsigned int index;
78     static char *OFIErrorStrings[] =
79     {
80         "%s(%d): Object Image Load Failure\n",
81         "%s(%d): Object Image Load Success\n",
82         "%s(%d): Not an recognisable object file\n",
83         "%s(%d): No valid architecture\n",
84         "%s(%d): Object image has an invalid format\n",
85         "%s(%d): Invalid access (permissions?)\n",
86         "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
87     };
88 #define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
89
90     switch (type)
91     {
92     case OFImage:
93         index = number;
94         if (index > NUM_OFI_ERRORS - 1)
95             index = NUM_OFI_ERRORS - 1;
96         error = form(OFIErrorStrings[index], path, number);
97         break;
98
99     default:
100         error = form("%s(%d): Totally unknown error type %d\n",
101                      path, number, type);
102         break;
103     }
104     Safefree(dl_last_error);
105     dl_last_error = savepv(error);
106 }
107
108 static char *dlopen(char *path, int mode /* mode is ignored */)
109 {
110     int dyld_result;
111     NSObjectFileImage ofile;
112     NSModule handle = NULL;
113
114     dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
115     if (dyld_result != NSObjectFileImageSuccess)
116         TranslateError(path, OFImage, dyld_result);
117     else
118     {
119         // NSLinkModule will cause the run to abort on any link error's
120         // not very friendly but the error recovery functionality is limited.
121         handle = NSLinkModule(ofile, path, TRUE);
122     }
123     
124     return handle;
125 }
126
127 void *
128 dlsym(handle, symbol)
129 void *handle;
130 char *symbol;
131 {
132     void *addr;
133
134     if (NSIsSymbolNameDefined(symbol))
135         addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
136     else
137         addr = NULL;
138
139     return addr;
140 }
141
142 #else /* NS_TARGET_MAJOR <= 3 */
143
144 static NXStream *OpenError(void)
145 {
146     return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY);
147 }
148
149 static void TransferError(NXStream *s)
150 {
151     char *buffer;
152     int len, maxlen;
153
154     if ( dl_last_error ) {
155         Safefree(dl_last_error);
156     }
157     NXGetMemoryBuffer(s, &buffer, &len, &maxlen);
158     New(1097, dl_last_error, len, char);
159     strcpy(dl_last_error, buffer);
160 }
161
162 static void CloseError(NXStream *s)
163 {
164     if ( s ) {
165       NXCloseMemory( s, NX_FREEBUFFER);
166     }
167 }
168
169 static char *dlopen(char *path, int mode /* mode is ignored */)
170 {
171     int rld_success;
172     NXStream *nxerr;
173     I32 i, psize;
174     char *result;
175     char **p;
176     STRLEN n_a;
177         
178     /* Do not load what is already loaded into this process */
179     if (hv_fetch(dl_loaded_files, path, strlen(path), 0))
180         return path;
181
182     nxerr = OpenError();
183     psize = AvFILL(dl_resolve_using) + 3;
184     p = (char **) safemalloc(psize * sizeof(char*));
185     p[0] = path;
186     for(i=1; i<psize-1; i++) {
187         p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a);
188     }
189     p[psize-1] = 0;
190     rld_success = rld_load(nxerr, (struct mach_header **)0, p,
191                             (const char *) 0);
192     safefree((char*) p);
193     if (rld_success) {
194         result = path;
195         /* prevent multiple loads of same file into same process */
196         hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0);
197     } else {
198         TransferError(nxerr);
199         result = (char*) 0;
200     }
201     CloseError(nxerr);
202     return result;
203 }
204
205 void *
206 dlsym(handle, symbol)
207 void *handle;
208 char *symbol;
209 {
210     NXStream    *nxerr = OpenError();
211     unsigned long       symref = 0;
212
213     if (!rld_lookup(nxerr, form("_%s", symbol), &symref))
214         TransferError(nxerr);
215     CloseError(nxerr);
216     return (void*) symref;
217 }
218
219 #endif /* NS_TARGET_MAJOR >= 4 */
220
221
222 /* ----- code from dl_dlopen.xs below here ----- */
223
224
225 static void
226 dl_private_init(pTHX)
227 {
228     (void)dl_generic_private_init(aTHX);
229     dl_resolve_using = get_av("DynaLoader::dl_resolve_using", 0x4);
230 }
231  
232 MODULE = DynaLoader     PACKAGE = DynaLoader
233
234 BOOT:
235     (void)dl_private_init(aTHX);
236
237
238
239 void *
240 dl_load_file(filename, flags=0)
241     char *      filename
242     int         flags
243     PREINIT:
244     int mode = 1;
245     CODE:
246     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
247     if (flags & 0x01)
248         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
249     RETVAL = dlopen(filename, mode) ;
250     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
251     ST(0) = sv_newmortal() ;
252     if (RETVAL == NULL)
253         SaveError(aTHX_ "%s",dlerror()) ;
254     else
255         sv_setiv( ST(0), PTR2IV(RETVAL) );
256
257
258 void *
259 dl_find_symbol(libhandle, symbolname)
260     void *              libhandle
261     char *              symbolname
262     CODE:
263 #if NS_TARGET_MAJOR >= 4
264     symbolname = form("_%s", symbolname);
265 #endif
266     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
267                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
268                              (unsigned long) libhandle, symbolname));
269     RETVAL = dlsym(libhandle, symbolname);
270     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
271                              "  symbolref = %lx\n", (unsigned long) RETVAL));
272     ST(0) = sv_newmortal() ;
273     if (RETVAL == NULL)
274         SaveError(aTHX_ "%s",dlerror()) ;
275     else
276         sv_setiv( ST(0), PTR2IV(RETVAL) );
277
278
279 void
280 dl_undef_symbols()
281     PPCODE:
282
283
284
285 # These functions should not need changing on any platform:
286
287 void
288 dl_install_xsub(perl_name, symref, filename="$Package")
289     char *      perl_name
290     void *      symref 
291     char *      filename
292     CODE:
293     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
294             perl_name, symref));
295     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
296                                         (void(*)(pTHX_ CV *))symref,
297                                         filename)));
298
299
300 char *
301 dl_error()
302     CODE:
303     RETVAL = LastError ;
304     OUTPUT:
305     RETVAL
306
307 # end.