ext/DynaLoader/dl_next.xs

   1 /* dl_next.xs
   2  *
   3  * Platform:    NeXT NS 3.2
   4  * Author:      Anno Siegel (siegel@zrz.TU-Berlin.DE)
   5  * Based on:    dl_dlopen.xs by Paul Marquess
   6  * Created:     Aug 15th, 1994
   7  *
   8  */
   9
  10 /*
  11     And Gandalf said: 'Many folk like to know beforehand what is to
  12     be set on the table; but those who have laboured to prepare the
  13     feast like to keep their secret; for wonder makes the words of
  14     praise louder.'
  15 */
  16
  17 /* Porting notes:
  18
  19 dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess.  It
  20 should not be used as a base for further ports though it may be used
  21 as an example for how dl_dlopen.xs can be ported to other platforms.
  22
  23 The method used here is just to supply the sun style dlopen etc.
  24 functions in terms of NeXTs rld_*.  The xs code proper is unchanged
  25 from Paul's original.
  26
  27 The port could use some streamlining.  For one, error handling could
  28 be simplified.
  29
  30 Anno Siegel
  31
  32 */
  33
  34 #if NS_TARGET_MAJOR >= 4
  35 #else
  36 /* include these before perl headers */
  37 #include <mach-o/rld.h>
  38 #include <streams/streams.h>
  39 #endif
  40
  41 #include "EXTERN.h"
  42 #include "perl.h"
  43 #include "XSUB.h"
  44
  45 #define DL_LOADONCEONLY
  46
  47 #include "dlutils.c"    /* SaveError() etc      */
  48
  49
  50 static char * dl_last_error = (char *) 0;
  51 static AV *dl_resolve_using = Nullav;
  52
  53 static char *dlerror()
  54 {
  55     return dl_last_error;
  56 }
  57
  58 int dlclose(handle) /* stub only */
  59 void *handle;
  60 {
  61     return 0;
  62 }
  63
  64 #if NS_TARGET_MAJOR >= 4
  65 #import <mach-o/dyld.h>
  66
  67 enum dyldErrorSource
  68 {
  69     OFImage,
  70 };
  71
  72 static void TranslateError
  73     (const char *path, enum dyldErrorSource type, int number)
  74 {
  75     dTHX;
  76     char *error;
  77     unsigned int index;
  78     static char *OFIErrorStrings[] =
  79     {
  80         "%s(%d): Object Image Load Failure\n",
  81         "%s(%d): Object Image Load Success\n",
  82         "%s(%d): Not an recognisable object file\n",
  83         "%s(%d): No valid architecture\n",
  84         "%s(%d): Object image has an invalid format\n",
  85         "%s(%d): Invalid access (permissions?)\n",
  86         "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
  87     };
  88 #define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
  89
  90     switch (type)
  91     {
  92     case OFImage:
  93         index = number;
  94         if (index > NUM_OFI_ERRORS - 1)
  95             index = NUM_OFI_ERRORS - 1;
  96         error = Perl_form_nocontext(OFIErrorStrings[index], path, number);
  97         break;
  98
  99     default:
 100         error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n",
 101                      path, number, type);
 102         break;
 103     }
 104     Safefree(dl_last_error);
 105     dl_last_error = savepv(error);
 106 }
 107
 108 static char *dlopen(char *path, int mode /* mode is ignored */)
 109 {
 110     int dyld_result;
 111     NSObjectFileImage ofile;
 112     NSModule handle = NULL;
 113
 114     dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
 115     if (dyld_result != NSObjectFileImageSuccess)
 116         TranslateError(path, OFImage, dyld_result);
 117     else
 118     {
 119         // NSLinkModule will cause the run to abort on any link error's
 120         // not very friendly but the error recovery functionality is limited.
 121         handle = NSLinkModule(ofile, path, TRUE);
 122     }
 123
 124     return handle;
 125 }
 126
 127 void *
 128 dlsym(handle, symbol)
 129 void *handle;
 130 char *symbol;
 131 {
 132     void *addr;
 133
 134     if (NSIsSymbolNameDefined(symbol))
 135         addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
 136     else
 137         addr = NULL;
 138
 139     return addr;
 140 }
 141
 142 #else /* NS_TARGET_MAJOR <= 3 */
 143
 144 static NXStream *OpenError(void)
 145 {
 146     return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY);
 147 }
 148
 149 static void TransferError(NXStream *s)
 150 {
 151     char *buffer;
 152     int len, maxlen;
 153
 154     if ( dl_last_error ) {
 155         Safefree(dl_last_error);
 156     }
 157     NXGetMemoryBuffer(s, &buffer, &len, &maxlen);
 158     New(1097, dl_last_error, len, char);
 159     strcpy(dl_last_error, buffer);
 160 }
 161
 162 static void CloseError(NXStream *s)
 163 {
 164     if ( s ) {
 165       NXCloseMemory( s, NX_FREEBUFFER);
 166     }
 167 }
 168
 169 static char *dlopen(char *path, int mode /* mode is ignored */)
 170 {
 171     int rld_success;
 172     NXStream *nxerr;
 173     I32 i, psize;
 174     char *result;
 175     char **p;
 176     STRLEN n_a;
 177
 178     /* Do not load what is already loaded into this process */
 179     if (hv_fetch(dl_loaded_files, path, strlen(path), 0))
 180         return path;
 181
 182     nxerr = OpenError();
 183     psize = AvFILL(dl_resolve_using) + 3;
 184     p = (char **) safemalloc(psize * sizeof(char*));
 185     p[0] = path;
 186     for(i=1; i<psize-1; i++) {
 187         p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a);
 188     }
 189     p[psize-1] = 0;
 190     rld_success = rld_load(nxerr, (struct mach_header **)0, p,
 191                             (const char *) 0);
 192     safefree((char*) p);
 193     if (rld_success) {
 194         result = path;
 195         /* prevent multiple loads of same file into same process */
 196         hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0);
 197     } else {
 198         TransferError(nxerr);
 199         result = (char*) 0;
 200     }
 201     CloseError(nxerr);
 202     return result;
 203 }
 204
 205 void *
 206 dlsym(handle, symbol)
 207 void *handle;
 208 char *symbol;
 209 {
 210     NXStream    *nxerr = OpenError();
 211     unsigned long       symref = 0;
 212
 213     if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref))
 214         TransferError(nxerr);
 215     CloseError(nxerr);
 216     return (void*) symref;
 217 }
 218
 219 #endif /* NS_TARGET_MAJOR >= 4 */
 220
 221
 222 /* ----- code from dl_dlopen.xs below here ----- */
 223
 224
 225 static void
 226 dl_private_init(pTHX)
 227 {
 228     (void)dl_generic_private_init(aTHX);
 229     dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
 230 }
 231
 232 MODULE = DynaLoader     PACKAGE = DynaLoader
 233
 234 BOOT:
 235     (void)dl_private_init(aTHX);
 236
 237
 238
 239 void *
 240 dl_load_file(filename, flags=0)
 241     char *      filename
 242     int         flags
 243     PREINIT:
 244     int mode = 1;
 245     CODE:
 246     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
 247     if (flags & 0x01)
 248         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
 249     RETVAL = dlopen(filename, mode) ;
 250     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
 251     ST(0) = sv_newmortal() ;
 252     if (RETVAL == NULL)
 253         SaveError(aTHX_ "%s",dlerror()) ;
 254     else
 255         sv_setiv( ST(0), PTR2IV(RETVAL) );
 256
 257
 258 void *
 259 dl_find_symbol(libhandle, symbolname)
 260     void *              libhandle
 261     char *              symbolname
 262     CODE:
 263 #if NS_TARGET_MAJOR >= 4
 264     symbolname = Perl_form_nocontext("_%s", symbolname);
 265 #endif
 266     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 267                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
 268                              (unsigned long) libhandle, symbolname));
 269     RETVAL = dlsym(libhandle, symbolname);
 270     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 271                              "  symbolref = %lx\n", (unsigned long) RETVAL));
 272     ST(0) = sv_newmortal() ;
 273     if (RETVAL == NULL)
 274         SaveError(aTHX_ "%s",dlerror()) ;
 275     else
 276         sv_setiv( ST(0), PTR2IV(RETVAL) );
 277
 278
 279 void
 280 dl_undef_symbols()
 281     PPCODE:
 282
 283
 284
 285 # These functions should not need changing on any platform:
 286
 287 void
 288 dl_install_xsub(perl_name, symref, filename="$Package")
 289     char *      perl_name
 290     void *      symref
 291     char *      filename
 292     CODE:
 293     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
 294             perl_name, symref));
 295     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
 296                                         (void(*)(pTHX_ CV *))symref,
 297                                         filename)));
 298
 299
 300 char *
 301 dl_error()
 302     CODE:
 303     RETVAL = LastError ;
 304     OUTPUT:
 305     RETVAL
 306
 307 # end.