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     void *retv;
 261     CODE:
 262     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
 263     if (flags & 0x01)
 264         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
 265     retv = dlopen(filename, mode) ;
 266     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", retv));
 267     ST(0) = sv_newmortal() ;
 268     if (retv == NULL)
 269         SaveError(aTHX_ "%s",dlerror()) ;
 270     else
 271         sv_setiv( ST(0), PTR2IV(retv) );
 272
 273
 274 void
 275 dl_find_symbol(libhandle, symbolname)
 276     void *              libhandle
 277     char *              symbolname
 278     PREINIT:
 279     void *retv;
 280     CODE:
 281 #if NS_TARGET_MAJOR >= 4
 282     symbolname = Perl_form_nocontext("_%s", symbolname);
 283 #endif
 284     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 285                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
 286                              (unsigned long) libhandle, symbolname));
 287     retv = dlsym(libhandle, symbolname);
 288     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 289                              "  symbolref = %lx\n", (unsigned long) retv));
 290     ST(0) = sv_newmortal() ;
 291     if (retv == NULL)
 292         SaveError(aTHX_ "%s",dlerror()) ;
 293     else
 294         sv_setiv( ST(0), PTR2IV(retv) );
 295
 296
 297 void
 298 dl_undef_symbols()
 299     CODE:
 300
 301
 302
 303 # These functions should not need changing on any platform:
 304
 305 void
 306 dl_install_xsub(perl_name, symref, filename="$Package")
 307     char *      perl_name
 308     void *      symref
 309     const char *        filename
 310     CODE:
 311     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
 312             perl_name, symref));
 313     ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
 314                                               (void(*)(pTHX_ CV *))symref,
 315                                               filename, NULL,
 316                                               XS_DYNAMIC_FILENAME)));
 317
 318
 319 char *
 320 dl_error()
 321     CODE:
 322     dMY_CXT;
 323     RETVAL = dl_last_error ;
 324     OUTPUT:
 325     RETVAL
 326
 327 #if defined(USE_ITHREADS)
 328
 329 void
 330 CLONE(...)
 331     CODE:
 332     MY_CXT_CLONE;
 333
 334     /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
 335      * using Perl variables that belong to another thread, we create our
 336      * own for this thread.
 337      */
 338     MY_CXT.x_dl_last_error = newSVpvn("", 0);
 339     dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
 340
 341 #endif
 342
 343 # end.