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 an 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     dMY_CXT;
 160
 161     if ( dl_last_error ) {
 162         Safefree(dl_last_error);
 163     }
 164     NXGetMemoryBuffer(s, &buffer, &len, &maxlen);
 165     New(1097, dl_last_error, len, char);
 166     strcpy(dl_last_error, buffer);
 167 }
 168
 169 static void CloseError(NXStream *s)
 170 {
 171     if ( s ) {
 172       NXCloseMemory( s, NX_FREEBUFFER);
 173     }
 174 }
 175
 176 static char *dlopen(char *path, int mode /* mode is ignored */)
 177 {
 178     int rld_success;
 179     NXStream *nxerr;
 180     I32 i, psize;
 181     char *result;
 182     char **p;
 183     STRLEN n_a;
 184     dMY_CXT;
 185
 186     /* Do not load what is already loaded into this process */
 187     if (hv_fetch(dl_loaded_files, path, strlen(path), 0))
 188         return path;
 189
 190     nxerr = OpenError();
 191     psize = AvFILL(dl_resolve_using) + 3;
 192     p = (char **) safemalloc(psize * sizeof(char*));
 193     p[0] = path;
 194     for(i=1; i<psize-1; i++) {
 195         p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a);
 196     }
 197     p[psize-1] = 0;
 198     rld_success = rld_load(nxerr, (struct mach_header **)0, p,
 199                             (const char *) 0);
 200     safefree((char*) p);
 201     if (rld_success) {
 202         result = path;
 203         /* prevent multiple loads of same file into same process */
 204         hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0);
 205     } else {
 206         TransferError(nxerr);
 207         result = (char*) 0;
 208     }
 209     CloseError(nxerr);
 210     return result;
 211 }
 212
 213 void *
 214 dlsym(handle, symbol)
 215 void *handle;
 216 char *symbol;
 217 {
 218     NXStream    *nxerr = OpenError();
 219     unsigned long       symref = 0;
 220
 221     if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref))
 222         TransferError(nxerr);
 223     CloseError(nxerr);
 224     return (void*) symref;
 225 }
 226
 227 #endif /* NS_TARGET_MAJOR >= 4 */
 228
 229
 230 /* ----- code from dl_dlopen.xs below here ----- */
 231
 232
 233 static void
 234 dl_private_init(pTHX)
 235 {
 236     (void)dl_generic_private_init(aTHX);
 237     {
 238         dMY_CXT;
 239         dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
 240     }
 241 }
 242
 243 MODULE = DynaLoader     PACKAGE = DynaLoader
 244
 245 BOOT:
 246     (void)dl_private_init(aTHX);
 247
 248
 249
 250 void *
 251 dl_load_file(filename, flags=0)
 252     char *      filename
 253     int         flags
 254     PREINIT:
 255     int mode = 1;
 256     CODE:
 257     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
 258     if (flags & 0x01)
 259         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
 260     RETVAL = dlopen(filename, mode) ;
 261     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
 262     ST(0) = sv_newmortal() ;
 263     if (RETVAL == NULL)
 264         SaveError(aTHX_ "%s",dlerror()) ;
 265     else
 266         sv_setiv( ST(0), PTR2IV(RETVAL) );
 267
 268
 269 void *
 270 dl_find_symbol(libhandle, symbolname)
 271     void *              libhandle
 272     char *              symbolname
 273     CODE:
 274 #if NS_TARGET_MAJOR >= 4
 275     symbolname = Perl_form_nocontext("_%s", symbolname);
 276 #endif
 277     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 278                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
 279                              (unsigned long) libhandle, symbolname));
 280     RETVAL = dlsym(libhandle, symbolname);
 281     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 282                              "  symbolref = %lx\n", (unsigned long) RETVAL));
 283     ST(0) = sv_newmortal() ;
 284     if (RETVAL == NULL)
 285         SaveError(aTHX_ "%s",dlerror()) ;
 286     else
 287         sv_setiv( ST(0), PTR2IV(RETVAL) );
 288
 289
 290 void
 291 dl_undef_symbols()
 292     PPCODE:
 293
 294
 295
 296 # These functions should not need changing on any platform:
 297
 298 void
 299 dl_install_xsub(perl_name, symref, filename="$Package")
 300     char *      perl_name
 301     void *      symref
 302     char *      filename
 303     CODE:
 304     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
 305             perl_name, symref));
 306     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
 307                                         (void(*)(pTHX_ CV *))symref,
 308                                         filename)));
 309
 310
 311 char *
 312 dl_error()
 313     CODE:
 314     dMY_CXT;
 315     RETVAL = dl_last_error ;
 316     OUTPUT:
 317     RETVAL
 318
 319 # end.