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  *     [p.970 of _The Lord of the Rings_, VI/v: "The Steward and the King"]
  18  */
  19
  20 /* Porting notes:
  21
  22 dl_dyld.xs is based on dl_next.xs by Anno Siegel.
  23
  24 dl_next.xs is in turn a port from dl_dlopen.xs by Paul Marquess.  It
  25 should not be used as a base for further ports though it may be used
  26 as an example for how dl_dlopen.xs can be ported to other platforms.
  27
  28 The method used here is just to supply the sun style dlopen etc.
  29 functions in terms of NeXT's/Apple's dyld.  The xs code proper is
  30 unchanged from Paul's original.
  31
  32 The port could use some streamlining.  For one, error handling could
  33 be simplified.
  34
  35 This should be useable as a replacement for dl_next.xs, but it has not
  36 been tested on NeXT platforms.
  37
  38   Wilfredo Sanchez
  39
  40 */
  41
  42 #include "EXTERN.h"
  43 #include "perl.h"
  44 #include "XSUB.h"
  45
  46 #include "dlutils.c"    /* for SaveError() etc */
  47
  48 #undef environ
  49 #undef bool
  50 #import <mach-o/dyld.h>
  51
  52 static char *dlerror()
  53 {
  54     dTHX;
  55     dMY_CXT;
  56     return dl_last_error;
  57 }
  58
  59 static int dlclose(void *handle) /* stub only */
  60 {
  61     return 0;
  62 }
  63
  64 enum dyldErrorSource
  65 {
  66     OFImage,
  67 };
  68
  69 static void TranslateError
  70     (const char *path, enum dyldErrorSource type, int number)
  71 {
  72     dTHX;
  73     dMY_CXT;
  74     char *error;
  75     unsigned int index;
  76     static char *OFIErrorStrings[] =
  77     {
  78         "%s(%d): Object Image Load Failure\n",
  79         "%s(%d): Object Image Load Success\n",
  80         "%s(%d): Not a recognisable object file\n",
  81         "%s(%d): No valid architecture\n",
  82         "%s(%d): Object image has an invalid format\n",
  83         "%s(%d): Invalid access (permissions?)\n",
  84         "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
  85     };
  86 #define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
  87
  88     switch (type)
  89     {
  90     case OFImage:
  91         index = number;
  92         if (index > NUM_OFI_ERRORS - 1)
  93             index = NUM_OFI_ERRORS - 1;
  94         error = Perl_form_nocontext(OFIErrorStrings[index], path, number);
  95         break;
  96
  97     default:
  98         error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n",
  99                      path, number, type);
 100         break;
 101     }
 102     sv_setpv(MY_CXT.x_dl_last_error, 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 errors
 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 static void *
 126 dlsym(void *handle, char *symbol)
 127 {
 128     void *addr;
 129
 130     if (NSIsSymbolNameDefined(symbol))
 131         addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
 132     else
 133         addr = NULL;
 134
 135     return addr;
 136 }
 137
 138
 139
 140 /* ----- code from dl_dlopen.xs below here ----- */
 141
 142
 143 static void
 144 dl_private_init(pTHX)
 145 {
 146     (void)dl_generic_private_init(aTHX);
 147 }
 148
 149 MODULE = DynaLoader     PACKAGE = DynaLoader
 150
 151 BOOT:
 152     (void)dl_private_init(aTHX);
 153
 154
 155
 156 void *
 157 dl_load_file(filename, flags=0)
 158     char *      filename
 159     int         flags
 160     PREINIT:
 161     int mode = 1;
 162     CODE:
 163     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
 164     if (flags & 0x01)
 165         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
 166     RETVAL = dlopen(filename, mode) ;
 167     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
 168     ST(0) = sv_newmortal() ;
 169     if (RETVAL == NULL)
 170         SaveError(aTHX_ "%s",dlerror()) ;
 171     else
 172         sv_setiv( ST(0), PTR2IV(RETVAL) );
 173
 174
 175 void *
 176 dl_find_symbol(libhandle, symbolname)
 177     void *              libhandle
 178     char *              symbolname
 179     CODE:
 180     symbolname = Perl_form_nocontext("_%s", symbolname);
 181     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 182                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
 183                              (unsigned long) libhandle, symbolname));
 184     RETVAL = dlsym(libhandle, symbolname);
 185     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 186                              "  symbolref = %lx\n", (unsigned long) RETVAL));
 187     ST(0) = sv_newmortal() ;
 188     if (RETVAL == NULL)
 189         SaveError(aTHX_ "%s",dlerror()) ;
 190     else
 191         sv_setiv( ST(0), PTR2IV(RETVAL) );
 192
 193
 194 void
 195 dl_undef_symbols()
 196     PPCODE:
 197
 198
 199
 200 # These functions should not need changing on any platform:
 201
 202 void
 203 dl_install_xsub(perl_name, symref, filename="$Package")
 204     char *      perl_name
 205     void *      symref
 206     const char *        filename
 207     CODE:
 208     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
 209             perl_name, symref));
 210     ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
 211                                               (void(*)(pTHX_ CV *))symref,
 212                                               filename, NULL,
 213                                               XS_DYNAMIC_FILENAME)));
 214
 215
 216 char *
 217 dl_error()
 218     CODE:
 219     dMY_CXT;
 220     RETVAL = dl_last_error ;
 221     OUTPUT:
 222     RETVAL
 223
 224 #if defined(USE_ITHREADS)
 225
 226 void
 227 CLONE(...)
 228     CODE:
 229     MY_CXT_CLONE;
 230
 231     /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
 232      * using Perl variables that belong to another thread, we create our
 233      * own for this thread.
 234      */
 235     MY_CXT.x_dl_last_error = newSVpvn("", 0);
 236
 237 #endif
 238
 239 # end.