This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Rhapsody/Darwin patches from Wilfredo Sanchez.
[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 #define DL_LOADONCEONLY
45
46 #include "dlutils.c"    /* SaveError() etc      */
47
48 #undef environ
49 #undef bool
50 #import <mach-o/dyld.h>
51
52 static char * dl_last_error = (char *) 0;
53 static AV *dl_resolve_using = Nullav;
54
55 static char *dlerror()
56 {
57     return dl_last_error;
58 }
59
60 int dlclose(handle) /* stub only */
61 void *handle;
62 {
63     return 0;
64 }
65
66 enum dyldErrorSource
67 {
68     OFImage,
69 };
70
71 static void TranslateError
72     (const char *path, enum dyldErrorSource type, int number)
73 {
74     dTHX;
75     char *error;
76     unsigned int index;
77     static char *OFIErrorStrings[] =
78     {
79         "%s(%d): Object Image Load Failure\n",
80         "%s(%d): Object Image Load Success\n",
81         "%s(%d): Not an recognisable object file\n",
82         "%s(%d): No valid architecture\n",
83         "%s(%d): Object image has an invalid format\n",
84         "%s(%d): Invalid access (permissions?)\n",
85         "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
86     };
87 #define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
88
89     switch (type)
90     {
91     case OFImage:
92         index = number;
93         if (index > NUM_OFI_ERRORS - 1)
94             index = NUM_OFI_ERRORS - 1;
95         error = Perl_form_nocontext(OFIErrorStrings[index], path, number);
96         break;
97
98     default:
99         error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n",
100                      path, number, type);
101         break;
102     }
103     safefree(dl_last_error);
104     dl_last_error = savepv(error);
105 }
106
107 static char *dlopen(char *path, int mode /* mode is ignored */)
108 {
109     int dyld_result;
110     NSObjectFileImage ofile;
111     NSModule handle = NULL;
112
113     dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
114     if (dyld_result != NSObjectFileImageSuccess)
115         TranslateError(path, OFImage, dyld_result);
116     else
117     {
118         // NSLinkModule will cause the run to abort on any link error's
119         // not very friendly but the error recovery functionality is limited.
120         handle = NSLinkModule(ofile, path, TRUE);
121     }
122
123     return handle;
124 }
125
126 void *
127 dlsym(handle, symbol)
128 void *handle;
129 char *symbol;
130 {
131     void *addr;
132
133     if (NSIsSymbolNameDefined(symbol))
134         addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
135     else
136         addr = NULL;
137
138     return addr;
139 }
140
141
142
143 /* ----- code from dl_dlopen.xs below here ----- */
144
145
146 static void
147 dl_private_init(pTHX)
148 {
149     (void)dl_generic_private_init(aTHX);
150     dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
151 }
152
153 MODULE = DynaLoader     PACKAGE = DynaLoader
154
155 BOOT:
156     (void)dl_private_init(aTHX);
157
158
159
160 void *
161 dl_load_file(filename, flags=0)
162     char *      filename
163     int         flags
164     PREINIT:
165     int mode = 1;
166     CODE:
167     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
168     if (flags & 0x01)
169         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
170     RETVAL = dlopen(filename, mode) ;
171     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
172     ST(0) = sv_newmortal() ;
173     if (RETVAL == NULL)
174         SaveError(aTHX_ "%s",dlerror()) ;
175     else
176         sv_setiv( ST(0), PTR2IV(RETVAL) );
177
178
179 void *
180 dl_find_symbol(libhandle, symbolname)
181     void *              libhandle
182     char *              symbolname
183     CODE:
184     symbolname = Perl_form_nocontext("_%s", symbolname);
185     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
186                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
187                              (unsigned long) libhandle, symbolname));
188     RETVAL = dlsym(libhandle, symbolname);
189     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
190                              "  symbolref = %lx\n", (unsigned long) RETVAL));
191     ST(0) = sv_newmortal() ;
192     if (RETVAL == NULL)
193         SaveError(aTHX_ "%s",dlerror()) ;
194     else
195         sv_setiv( ST(0), PTR2IV(RETVAL) );
196
197
198 void
199 dl_undef_symbols()
200     PPCODE:
201
202
203
204 # These functions should not need changing on any platform:
205
206 void
207 dl_install_xsub(perl_name, symref, filename="$Package")
208     char *      perl_name
209     void *      symref
210     char *      filename
211     CODE:
212     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
213             perl_name, symref));
214     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
215                                         (void(*)(pTHX_ CV *))symref,
216                                         filename)));
217
218
219 char *
220 dl_error()
221     CODE:
222     RETVAL = LastError ;
223     OUTPUT:
224     RETVAL
225
226 # end.