X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FDynaLoader%2Fdl_next.xs;h=265800b2af8dbea1cb2cf51a4186f8bd6395476e;hb=ef7e80c4ffb0d80daa17dc6be88a4595251bdd51;hp=9bc5cd81c25148f358771dff81ecdb151bf2700b;hpb=a0d0e21ea6ea90a22318550944fe6cb09ae10cda;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/DynaLoader/dl_next.xs b/ext/DynaLoader/dl_next.xs index 9bc5cd8..265800b 100644 --- a/ext/DynaLoader/dl_next.xs +++ b/ext/DynaLoader/dl_next.xs @@ -31,72 +31,170 @@ Anno Siegel */ +#if NS_TARGET_MAJOR >= 4 +#else +/* include these before perl headers */ +#include +#include +#endif + #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#define DL_LOADONCEONLY + +typedef struct { + AV * x_resolve_using; +} my_cxtx_t; /* this *must* be named my_cxtx_t */ + +#define DL_CXT_EXTRA /* ask for dl_cxtx to be defined in dlutils.c */ #include "dlutils.c" /* SaveError() etc */ +#define dl_resolve_using (dl_cxtx.x_resolve_using) -#include -#include +static char *dlerror() +{ + dTHX; + dMY_CXT; + return dl_last_error; +} + +int dlclose(handle) /* stub only */ +void *handle; +{ + return 0; +} + +#if NS_TARGET_MAJOR >= 4 +#import + +enum dyldErrorSource +{ + OFImage, +}; + +static void TranslateError + (const char *path, enum dyldErrorSource type, int number) +{ + dTHX; + dMY_CXT; + char *error; + unsigned int index; + static char *OFIErrorStrings[] = + { + "%s(%d): Object Image Load Failure\n", + "%s(%d): Object Image Load Success\n", + "%s(%d): Not a recognisable object file\n", + "%s(%d): No valid architecture\n", + "%s(%d): Object image has an invalid format\n", + "%s(%d): Invalid access (permissions?)\n", + "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n", + }; +#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0])) + + switch (type) + { + case OFImage: + index = number; + if (index > NUM_OFI_ERRORS - 1) + index = NUM_OFI_ERRORS - 1; + error = Perl_form_nocontext(OFIErrorStrings[index], path, number); + break; + + default: + error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n", + path, number, type); + break; + } + Safefree(dl_last_error); + dl_last_error = savepv(error); +} + +static char *dlopen(char *path, int mode /* mode is ignored */) +{ + int dyld_result; + NSObjectFileImage ofile; + NSModule handle = NULL; + + dyld_result = NSCreateObjectFileImageFromFile(path, &ofile); + if (dyld_result != NSObjectFileImageSuccess) + TranslateError(path, OFImage, dyld_result); + else + { + // NSLinkModule will cause the run to abort on any link error's + // not very friendly but the error recovery functionality is limited. + handle = NSLinkModule(ofile, path, TRUE); + } + + return handle; +} -static char * dl_last_error = (char *) 0; +void * +dlsym(handle, symbol) +void *handle; +char *symbol; +{ + void *addr; + + if (NSIsSymbolNameDefined(symbol)) + addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol)); + else + addr = NULL; -NXStream * -OpenError() + return addr; +} + +#else /* NS_TARGET_MAJOR <= 3 */ + +static NXStream *OpenError(void) { return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY); } -void -TransferError( s) -NXStream *s; +static void TransferError(NXStream *s) { char *buffer; int len, maxlen; + dTHX; + dMY_CXT; if ( dl_last_error ) { - safefree(dl_last_error); + Safefree(dl_last_error); } NXGetMemoryBuffer(s, &buffer, &len, &maxlen); - dl_last_error = safemalloc(len); + Newx(dl_last_error, len, char); strcpy(dl_last_error, buffer); } -void -CloseError( s) -NXStream *s; +static void CloseError(NXStream *s) { if ( s ) { NXCloseMemory( s, NX_FREEBUFFER); } } -char *dlerror() -{ - return dl_last_error; -} - -char * -dlopen(path, mode) -char * path; -int mode; /* mode is ignored */ +static char *dlopen(char *path, int mode /* mode is ignored */) { int rld_success; - NXStream *nxerr = OpenError(); - AV * av_resolve; + NXStream *nxerr; I32 i, psize; char *result; char **p; - - av_resolve = GvAVn(gv_fetchpv( - "DynaLoader::dl_resolve_using", FALSE, SVt_PVAV)); - psize = AvFILL(av_resolve) + 3; + STRLEN n_a; + dTHX; + dMY_CXT; + + /* Do not load what is already loaded into this process */ + if (hv_fetch(dl_loaded_files, path, strlen(path), 0)) + return path; + + nxerr = OpenError(); + psize = AvFILL(dl_resolve_using) + 3; p = (char **) safemalloc(psize * sizeof(char*)); p[0] = path; for(i=1; i= 4 */ + /* ----- code from dl_dlopen.xs below here ----- */ static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); + (void)dl_generic_private_init(aTHX); + { + dMY_CXT; + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); + } } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * -dl_load_file(filename) +dl_load_file(filename, flags=0) char * filename - CODE: + int flags + PREINIT: int mode = 1; - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + CODE: + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); + if (flags & 0x01) + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); void * @@ -173,15 +273,20 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); +#if NS_TARGET_MAJOR >= 4 + symbolname = Perl_form_nocontext("_%s", symbolname); +#endif + DLDEBUG(2, PerlIO_printf(Perl_debug_log, + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + DLDEBUG(2, PerlIO_printf(Perl_debug_log, + " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); void @@ -198,15 +303,18 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * dl_error() CODE: - RETVAL = LastError ; + dMY_CXT; + RETVAL = dl_last_error ; OUTPUT: RETVAL