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