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