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_dyld.xs
1 /* dl_dyld.xs
2  *
3  * Platform:    Darwin (Mac OS)
4  * Author:      Wilfredo Sanchez <wsanchez@apple.com>
5  * Based on:    dl_next.xs by Paul Marquess
6  * Based on:    dl_dlopen.xs by Anno Siegel
7  * Created:     Aug 15th, 1994
8  *
9  */
10
11 /*
12     And Gandalf said: 'Many folk like to know beforehand what is to
13     be set on the table; but those who have laboured to prepare the
14     feast like to keep their secret; for wonder makes the words of
15     praise louder.'
16 */
17
18 /* Porting notes:
19
20 dl_dyld.xs is based on dl_next.xs by Anno Siegel.
21
22 dl_next.xs is in turn a port from dl_dlopen.xs by Paul Marquess.  It
23 should not be used as a base for further ports though it may be used
24 as an example for how dl_dlopen.xs can be ported to other platforms.
25
26 The method used here is just to supply the sun style dlopen etc.
27 functions in terms of NeXT's/Apple's dyld.  The xs code proper is
28 unchanged from Paul's original.
29
30 The port could use some streamlining.  For one, error handling could
31 be simplified.
32
33 This should be useable as a replacement for dl_next.xs, but it has not
34 been tested on NeXT platforms.
35
36   Wilfredo Sanchez
37
38 */
39
40 #include "EXTERN.h"
41 #include "perl.h"
42 #include "XSUB.h"
43
44 #include "dlutils.c"    /* for SaveError() etc */
45
46 #undef environ
47 #undef bool
48 #import <mach-o/dyld.h>
49
50 static char *dlerror()
51 {
52     dTHX;
53     dMY_CXT;
54     return dl_last_error;
55 }
56
57 static int dlclose(void *handle) /* stub only */
58 {
59     return 0;
60 }
61
62 enum dyldErrorSource
63 {
64     OFImage,
65 };
66
67 static void TranslateError
68     (const char *path, enum dyldErrorSource type, int number)
69 {
70     dTHX;
71     dMY_CXT;
72     char *error;
73     unsigned int index;
74     static char *OFIErrorStrings[] =
75     {
76         "%s(%d): Object Image Load Failure\n",
77         "%s(%d): Object Image Load Success\n",
78         "%s(%d): Not a recognisable object file\n",
79         "%s(%d): No valid architecture\n",
80         "%s(%d): Object image has an invalid format\n",
81         "%s(%d): Invalid access (permissions?)\n",
82         "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
83     };
84 #define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
85
86     switch (type)
87     {
88     case OFImage:
89         index = number;
90         if (index > NUM_OFI_ERRORS - 1)
91             index = NUM_OFI_ERRORS - 1;
92         error = Perl_form_nocontext(OFIErrorStrings[index], path, number);
93         break;
94
95     default:
96         error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n",
97                      path, number, type);
98         break;
99     }
100     sv_setpv(MY_CXT.x_dl_last_error, error);
101 }
102
103 static char *dlopen(char *path, int mode /* mode is ignored */)
104 {
105     int dyld_result;
106     NSObjectFileImage ofile;
107     NSModule handle = NULL;
108
109     dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
110     if (dyld_result != NSObjectFileImageSuccess)
111         TranslateError(path, OFImage, dyld_result);
112     else
113     {
114         // NSLinkModule will cause the run to abort on any link errors
115         // not very friendly but the error recovery functionality is limited.
116         handle = NSLinkModule(ofile, path, TRUE);
117         NSDestroyObjectFileImage(ofile);
118     }
119
120     return handle;
121 }
122
123 static void *
124 dlsym(void *handle, char *symbol)
125 {
126     void *addr;
127
128     if (NSIsSymbolNameDefined(symbol))
129         addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
130     else
131         addr = NULL;
132
133     return addr;
134 }
135
136
137
138 /* ----- code from dl_dlopen.xs below here ----- */
139
140
141 static void
142 dl_private_init(pTHX)
143 {
144     (void)dl_generic_private_init(aTHX);
145 }
146
147 MODULE = DynaLoader     PACKAGE = DynaLoader
148
149 BOOT:
150     (void)dl_private_init(aTHX);
151
152
153
154 void *
155 dl_load_file(filename, flags=0)
156     char *      filename
157     int         flags
158     PREINIT:
159     int mode = 1;
160     CODE:
161     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
162     if (flags & 0x01)
163         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
164     RETVAL = dlopen(filename, mode) ;
165     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
166     ST(0) = sv_newmortal() ;
167     if (RETVAL == NULL)
168         SaveError(aTHX_ "%s",dlerror()) ;
169     else
170         sv_setiv( ST(0), PTR2IV(RETVAL) );
171
172
173 void *
174 dl_find_symbol(libhandle, symbolname)
175     void *              libhandle
176     char *              symbolname
177     CODE:
178     symbolname = Perl_form_nocontext("_%s", symbolname);
179     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
180                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
181                              (unsigned long) libhandle, symbolname));
182     RETVAL = dlsym(libhandle, symbolname);
183     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
184                              "  symbolref = %lx\n", (unsigned long) RETVAL));
185     ST(0) = sv_newmortal() ;
186     if (RETVAL == NULL)
187         SaveError(aTHX_ "%s",dlerror()) ;
188     else
189         sv_setiv( ST(0), PTR2IV(RETVAL) );
190
191
192 void
193 dl_undef_symbols()
194     PPCODE:
195
196
197
198 # These functions should not need changing on any platform:
199
200 void
201 dl_install_xsub(perl_name, symref, filename="$Package")
202     char *      perl_name
203     void *      symref
204     char *      filename
205     CODE:
206     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
207             perl_name, symref));
208     ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
209                                               (void(*)(pTHX_ CV *))symref,
210                                               filename, NULL,
211                                               XS_DYNAMIC_FILENAME)));
212
213
214 char *
215 dl_error()
216     CODE:
217     dMY_CXT;
218     RETVAL = dl_last_error ;
219     OUTPUT:
220     RETVAL
221
222 # end.