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