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     }
 120
 121     return handle;
 122 }
 123
 124 void *
 125 dlsym(handle, symbol)
 126 void *handle;
 127 char *symbol;
 128 {
 129     void *addr;
 130
 131     if (NSIsSymbolNameDefined(symbol))
 132         addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
 133     else
 134         addr = NULL;
 135
 136     return addr;
 137 }
 138
 139
 140
 141 /* ----- code from dl_dlopen.xs below here ----- */
 142
 143
 144 static void
 145 dl_private_init(pTHX)
 146 {
 147     (void)dl_generic_private_init(aTHX);
 148 }
 149
 150 MODULE = DynaLoader     PACKAGE = DynaLoader
 151
 152 BOOT:
 153     (void)dl_private_init(aTHX);
 154
 155
 156
 157 void *
 158 dl_load_file(filename, flags=0)
 159     char *      filename
 160     int         flags
 161     PREINIT:
 162     int mode = 1;
 163     CODE:
 164     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
 165     if (flags & 0x01)
 166         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
 167     RETVAL = dlopen(filename, mode) ;
 168     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
 169     ST(0) = sv_newmortal() ;
 170     if (RETVAL == NULL)
 171         SaveError(aTHX_ "%s",dlerror()) ;
 172     else
 173         sv_setiv( ST(0), PTR2IV(RETVAL) );
 174
 175
 176 void *
 177 dl_find_symbol(libhandle, symbolname)
 178     void *              libhandle
 179     char *              symbolname
 180     CODE:
 181     symbolname = Perl_form_nocontext("_%s", symbolname);
 182     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 183                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
 184                              (unsigned long) libhandle, symbolname));
 185     RETVAL = dlsym(libhandle, symbolname);
 186     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 187                              "  symbolref = %lx\n", (unsigned long) RETVAL));
 188     ST(0) = sv_newmortal() ;
 189     if (RETVAL == NULL)
 190         SaveError(aTHX_ "%s",dlerror()) ;
 191     else
 192         sv_setiv( ST(0), PTR2IV(RETVAL) );
 193
 194
 195 void
 196 dl_undef_symbols()
 197     PPCODE:
 198
 199
 200
 201 # These functions should not need changing on any platform:
 202
 203 void
 204 dl_install_xsub(perl_name, symref, filename="$Package")
 205     char *      perl_name
 206     void *      symref
 207     char *      filename
 208     CODE:
 209     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
 210             perl_name, symref));
 211     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
 212                                         (void(*)(pTHX_ CV *))symref,
 213                                         filename)));
 214
 215
 216 char *
 217 dl_error()
 218     CODE:
 219     dMY_CXT;
 220     RETVAL = dl_last_error ;
 221     OUTPUT:
 222     RETVAL
 223
 224 # end.