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     safefree(dl_last_error);
 101     dl_last_error = savepv(error);
 102 }
 103
 104 static char *dlopen(char *path, int mode /* mode is ignored */)
 105 {
 106     int dyld_result;
 107     NSObjectFileImage ofile;
 108     NSModule handle = NULL;
 109
 110     dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
 111     if (dyld_result != NSObjectFileImageSuccess)
 112         TranslateError(path, OFImage, dyld_result);
 113     else
 114     {
 115         // NSLinkModule will cause the run to abort on any link errors
 116         // not very friendly but the error recovery functionality is limited.
 117         handle = NSLinkModule(ofile, path, TRUE);
 118         NSDestroyObjectFileImage(ofile);
 119     }
 120
 121     return handle;
 122 }
 123
 124 static void *
 125 dlsym(void *handle, char *symbol)
 126 {
 127     void *addr;
 128
 129     if (NSIsSymbolNameDefined(symbol))
 130         addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
 131     else
 132         addr = NULL;
 133
 134     return addr;
 135 }
 136
 137
 138
 139 /* ----- code from dl_dlopen.xs below here ----- */
 140
 141
 142 static void
 143 dl_private_init(pTHX)
 144 {
 145     (void)dl_generic_private_init(aTHX);
 146 }
 147
 148 MODULE = DynaLoader     PACKAGE = DynaLoader
 149
 150 BOOT:
 151     (void)dl_private_init(aTHX);
 152
 153
 154
 155 void *
 156 dl_load_file(filename, flags=0)
 157     char *      filename
 158     int         flags
 159     PREINIT:
 160     int mode = 1;
 161     CODE:
 162     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
 163     if (flags & 0x01)
 164         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
 165     RETVAL = dlopen(filename, mode) ;
 166     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
 167     ST(0) = sv_newmortal() ;
 168     if (RETVAL == NULL)
 169         SaveError(aTHX_ "%s",dlerror()) ;
 170     else
 171         sv_setiv( ST(0), PTR2IV(RETVAL) );
 172
 173
 174 void *
 175 dl_find_symbol(libhandle, symbolname)
 176     void *              libhandle
 177     char *              symbolname
 178     CODE:
 179     symbolname = Perl_form_nocontext("_%s", symbolname);
 180     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 181                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
 182                              (unsigned long) libhandle, symbolname));
 183     RETVAL = dlsym(libhandle, symbolname);
 184     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 185                              "  symbolref = %lx\n", (unsigned long) RETVAL));
 186     ST(0) = sv_newmortal() ;
 187     if (RETVAL == NULL)
 188         SaveError(aTHX_ "%s",dlerror()) ;
 189     else
 190         sv_setiv( ST(0), PTR2IV(RETVAL) );
 191
 192
 193 void
 194 dl_undef_symbols()
 195     PPCODE:
 196
 197
 198
 199 # These functions should not need changing on any platform:
 200
 201 void
 202 dl_install_xsub(perl_name, symref, filename="$Package")
 203     char *      perl_name
 204     void *      symref
 205     char *      filename
 206     CODE:
 207     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
 208             perl_name, symref));
 209     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
 210                                         (void(*)(pTHX_ CV *))symref,
 211                                         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.