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 typedef struct {
  48     AV *        x_resolve_using;
  49 } my_cxtx_t;            /* this *must* be named my_cxtx_t */
  50
  51 #define DL_CXT_EXTRA    /* ask for dl_cxtx to be defined in dlutils.c */
  52 #include "dlutils.c"    /* SaveError() etc      */
  53
  54 #define dl_resolve_using        (dl_cxtx.x_resolve_using)
  55
  56 static char *dlerror()
  57 {
  58     dTHX;
  59     dMY_CXT;
  60     return dl_last_error;
  61 }
  62
  63 int dlclose(handle) /* stub only */
  64 void *handle;
  65 {
  66     return 0;
  67 }
  68
  69 #if NS_TARGET_MAJOR >= 4
  70 #import <mach-o/dyld.h>
  71
  72 enum dyldErrorSource
  73 {
  74     OFImage,
  75 };
  76
  77 static void TranslateError
  78     (const char *path, enum dyldErrorSource type, int number)
  79 {
  80     dTHX;
  81     dMY_CXT;
  82     char *error;
  83     unsigned int index;
  84     static char *OFIErrorStrings[] =
  85     {
  86         "%s(%d): Object Image Load Failure\n",
  87         "%s(%d): Object Image Load Success\n",
  88         "%s(%d): Not a recognisable object file\n",
  89         "%s(%d): No valid architecture\n",
  90         "%s(%d): Object image has an invalid format\n",
  91         "%s(%d): Invalid access (permissions?)\n",
  92         "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
  93     };
  94 #define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
  95
  96     switch (type)
  97     {
  98     case OFImage:
  99         index = number;
 100         if (index > NUM_OFI_ERRORS - 1)
 101             index = NUM_OFI_ERRORS - 1;
 102         error = Perl_form_nocontext(OFIErrorStrings[index], path, number);
 103         break;
 104
 105     default:
 106         error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n",
 107                      path, number, type);
 108         break;
 109     }
 110     Safefree(dl_last_error);
 111     dl_last_error = savepv(error);
 112 }
 113
 114 static char *dlopen(char *path, int mode /* mode is ignored */)
 115 {
 116     int dyld_result;
 117     NSObjectFileImage ofile;
 118     NSModule handle = NULL;
 119
 120     dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
 121     if (dyld_result != NSObjectFileImageSuccess)
 122         TranslateError(path, OFImage, dyld_result);
 123     else
 124     {
 125         // NSLinkModule will cause the run to abort on any link error's
 126         // not very friendly but the error recovery functionality is limited.
 127         handle = NSLinkModule(ofile, path, TRUE);
 128     }
 129
 130     return handle;
 131 }
 132
 133 void *
 134 dlsym(handle, symbol)
 135 void *handle;
 136 char *symbol;
 137 {
 138     void *addr;
 139
 140     if (NSIsSymbolNameDefined(symbol))
 141         addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
 142     else
 143         addr = NULL;
 144
 145     return addr;
 146 }
 147
 148 #else /* NS_TARGET_MAJOR <= 3 */
 149
 150 static NXStream *OpenError(void)
 151 {
 152     return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY);
 153 }
 154
 155 static void TransferError(NXStream *s)
 156 {
 157     char *buffer;
 158     int len, maxlen;
 159     dTHX;
 160     dMY_CXT;
 161
 162     if ( dl_last_error ) {
 163         Safefree(dl_last_error);
 164     }
 165     NXGetMemoryBuffer(s, &buffer, &len, &maxlen);
 166     Newx(dl_last_error, len, char);
 167     strcpy(dl_last_error, buffer);
 168 }
 169
 170 static void CloseError(NXStream *s)
 171 {
 172     if ( s ) {
 173       NXCloseMemory( s, NX_FREEBUFFER);
 174     }
 175 }
 176
 177 static char *dlopen(char *path, int mode /* mode is ignored */)
 178 {
 179     int rld_success;
 180     NXStream *nxerr;
 181     I32 i, psize;
 182     char *result;
 183     char **p;
 184     STRLEN n_a;
 185     dTHX;
 186     dMY_CXT;
 187
 188     /* Do not load what is already loaded into this process */
 189     if (hv_fetch(dl_loaded_files, path, strlen(path), 0))
 190         return path;
 191
 192     nxerr = OpenError();
 193     psize = AvFILL(dl_resolve_using) + 3;
 194     p = (char **) safemalloc(psize * sizeof(char*));
 195     p[0] = path;
 196     for(i=1; i<psize-1; i++) {
 197         p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a);
 198     }
 199     p[psize-1] = 0;
 200     rld_success = rld_load(nxerr, (struct mach_header **)0, p,
 201                             (const char *) 0);
 202     safefree((char*) p);
 203     if (rld_success) {
 204         result = path;
 205         /* prevent multiple loads of same file into same process */
 206         hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0);
 207     } else {
 208         TransferError(nxerr);
 209         result = (char*) 0;
 210     }
 211     CloseError(nxerr);
 212     return result;
 213 }
 214
 215 void *
 216 dlsym(handle, symbol)
 217 void *handle;
 218 char *symbol;
 219 {
 220     NXStream    *nxerr = OpenError();
 221     unsigned long       symref = 0;
 222
 223     if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref))
 224         TransferError(nxerr);
 225     CloseError(nxerr);
 226     return (void*) symref;
 227 }
 228
 229 #endif /* NS_TARGET_MAJOR >= 4 */
 230
 231
 232 /* ----- code from dl_dlopen.xs below here ----- */
 233
 234
 235 static void
 236 dl_private_init(pTHX)
 237 {
 238     (void)dl_generic_private_init(aTHX);
 239     {
 240         dMY_CXT;
 241         dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
 242     }
 243 }
 244
 245 MODULE = DynaLoader     PACKAGE = DynaLoader
 246
 247 BOOT:
 248     (void)dl_private_init(aTHX);
 249
 250
 251
 252 void *
 253 dl_load_file(filename, flags=0)
 254     char *      filename
 255     int         flags
 256     PREINIT:
 257     int mode = 1;
 258     CODE:
 259     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
 260     if (flags & 0x01)
 261         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
 262     RETVAL = dlopen(filename, mode) ;
 263     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
 264     ST(0) = sv_newmortal() ;
 265     if (RETVAL == NULL)
 266         SaveError(aTHX_ "%s",dlerror()) ;
 267     else
 268         sv_setiv( ST(0), PTR2IV(RETVAL) );
 269
 270
 271 void *
 272 dl_find_symbol(libhandle, symbolname)
 273     void *              libhandle
 274     char *              symbolname
 275     CODE:
 276 #if NS_TARGET_MAJOR >= 4
 277     symbolname = Perl_form_nocontext("_%s", symbolname);
 278 #endif
 279     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 280                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
 281                              (unsigned long) libhandle, symbolname));
 282     RETVAL = dlsym(libhandle, symbolname);
 283     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 284                              "  symbolref = %lx\n", (unsigned long) RETVAL));
 285     ST(0) = sv_newmortal() ;
 286     if (RETVAL == NULL)
 287         SaveError(aTHX_ "%s",dlerror()) ;
 288     else
 289         sv_setiv( ST(0), PTR2IV(RETVAL) );
 290
 291
 292 void
 293 dl_undef_symbols()
 294     PPCODE:
 295
 296
 297
 298 # These functions should not need changing on any platform:
 299
 300 void
 301 dl_install_xsub(perl_name, symref, filename="$Package")
 302     char *      perl_name
 303     void *      symref
 304     char *      filename
 305     CODE:
 306     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
 307             perl_name, symref));
 308     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
 309                                         (void(*)(pTHX_ CV *))symref,
 310                                         filename)));
 311
 312
 313 char *
 314 dl_error()
 315     CODE:
 316     dMY_CXT;
 317     RETVAL = dl_last_error ;
 318     OUTPUT:
 319     RETVAL
 320
 321 # end.