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(perl_name,
 209                                         (void(*)(pTHX_ CV *))symref,
 210                                         filename)));
 211
 212
 213 char *
 214 dl_error()
 215     CODE:
 216     dMY_CXT;
 217     RETVAL = dl_last_error ;
 218     OUTPUT:
 219     RETVAL
 220
 221 # end.