X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FDynaLoader%2Fdl_vms.xs;h=6ebcd9bfaaaa75efd5ed4365b20ac7048d280e86;hb=444c2e40cd0ea36b829c3148c73f26229f0ec7aa;hp=c6e58fb33c4d9447ef933f0a4d70f459b0ec3b9f;hpb=748a93069b3d16374a9859d1456065dd3ae11394;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs index c6e58fb..6ebcd9b 100644 --- a/ext/DynaLoader/dl_vms.xs +++ b/ext/DynaLoader/dl_vms.xs @@ -1,8 +1,8 @@ /* dl_vms.xs * - * Platform: OpenVMS, VAX or AXP - * Author: Charles Bailey bailey@genetics.upenn.edu - * Revised: 12-Dec-1994 + * Platform: OpenVMS, VAX or AXP or IA64 + * Author: Charles Bailey bailey@newman.upenn.edu + * Revised: See http://public.activestate.com/cgi-bin/perlbrowse * * Implementation Note * This section is added as an aid to users and DynaLoader developers, in @@ -49,12 +49,6 @@ #include "perl.h" #include "XSUB.h" -#include "dlutils.c" /* dl_debug, LastError; SaveError not used */ -/* N.B.: - * dl_debug and LastError are static vars; you'll need to deal - * with them appropriately if you need context independence - */ - #include #include #include @@ -62,6 +56,12 @@ #include #include +#if defined(VMS_WE_ARE_CASE_SENSITIVE) +#define DL_CASE_SENSITIVE 1<<4 +#else +#define DL_CASE_SENSITIVE 0 +#endif + typedef unsigned long int vmssts; struct libref { @@ -69,35 +69,53 @@ struct libref { struct dsc$descriptor_s defspec; }; -/* Static data for dl_expand_filespec() - This is static to save +typedef struct { + AV * x_require_symbols; +/* "Static" data for dl_expand_filespec() - This is static to save * initialization on each call; if you need context-independence, * just make these auto variables in dl_expandspec() and dl_load_file() */ -static char dlesa[NAM$C_MAXRSS], dlrsa[NAM$C_MAXRSS]; -static struct FAB dlfab; -static struct NAM dlnam; + char x_esa[NAM$C_MAXRSS]; + char x_rsa[NAM$C_MAXRSS]; + struct FAB x_fab; + struct NAM x_nam; +} 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" /* dl_debug, dl_last_error; SaveError not used */ + +#define dl_require_symbols (dl_cxtx.x_require_symbols) +#define dl_esa (dl_cxtx.x_esa) +#define dl_rsa (dl_cxtx.x_rsa) +#define dl_fab (dl_cxtx.x_fab) +#define dl_nam (dl_cxtx.x_nam) -/* $PutMsg action routine - records error message in LastError */ +/* $PutMsg action routine - records error message in dl_last_error */ static vmssts copy_errmsg(msg,unused) struct dsc$descriptor_s * msg; vmssts unused; { + dTHX; + dMY_CXT; if (*(msg->dsc$a_pointer) == '%') { /* first line */ - if (LastError) - strncpy((LastError = saferealloc(LastError,msg->dsc$w_length)), + if (dl_last_error) + strncpy((dl_last_error = saferealloc(dl_last_error,msg->dsc$w_length+1)), msg->dsc$a_pointer, msg->dsc$w_length); else - strncpy((LastError = safemalloc(msg->dsc$w_length)), + strncpy((dl_last_error = safemalloc(msg->dsc$w_length+1)), msg->dsc$a_pointer, msg->dsc$w_length); - return 0; + dl_last_error[msg->dsc$w_length] = '\0'; } else { /* continuation line */ - int errlen = strlen(LastError); - LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 1); - LastError[errlen] = '\n'; LastError[errlen+1] = '\0'; - strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length); + int errlen = strlen(dl_last_error); + dl_last_error = saferealloc(dl_last_error, errlen + msg->dsc$w_length + 2); + dl_last_error[errlen] = '\n'; dl_last_error[errlen+1] = '\0'; + strncat(dl_last_error, msg->dsc$a_pointer, msg->dsc$w_length); + dl_last_error[errlen+msg->dsc$w_length+1] = '\0'; } + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "Saved error message: %s\n", dl_last_error)); + return 0; } /* Use $PutMsg to retrieve error message for failure status code */ @@ -107,29 +125,49 @@ dl_set_error(sts,stv) vmssts stv; { vmssts vec[3]; + dTHX; vec[0] = stv ? 2 : 1; vec[1] = sts; vec[2] = stv; _ckvmssts(sys$putmsg(vec,copy_errmsg,0,0)); } +/* wrapper for lib$find_image_symbol, so signalled errors can be saved + * for dl_error and then returned */ +static unsigned long int +my_find_image_symbol(struct dsc$descriptor_s *imgname, + struct dsc$descriptor_s *symname, + void (**entry)(), + struct dsc$descriptor_s *defspec) +{ + unsigned long int retsts; + VAXC$ESTABLISH(lib$sig_to_ret); + retsts = lib$find_image_symbol(imgname,symname,entry,defspec,DL_CASE_SENSITIVE); + return retsts; +} + + static void -dl_private_init() +dl_private_init(pTHX) { - dl_generic_private_init(); - /* Set up the static control blocks for dl_expand_filespec() */ - dlfab = cc$rms_fab; - dlnam = cc$rms_nam; - dlfab.fab$l_nam = &dlnam; - dlnam.nam$l_esa = dlesa; - dlnam.nam$b_ess = sizeof dlesa; - dlnam.nam$l_rsa = dlrsa; - dlnam.nam$b_rss = sizeof dlrsa; + dl_generic_private_init(aTHX); + { + dMY_CXT; + dl_require_symbols = get_av("DynaLoader::dl_require_symbols", 0x4); + /* Set up the static control blocks for dl_expand_filespec() */ + dl_fab = cc$rms_fab; + dl_nam = cc$rms_nam; + dl_fab.fab$l_nam = &dl_nam; + dl_nam.nam$l_esa = dl_esa; + dl_nam.nam$b_ess = sizeof dl_esa; + dl_nam.nam$l_rsa = dl_rsa; + dl_nam.nam$b_rss = sizeof dl_rsa; + } } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void dl_expandspec(filespec) @@ -138,64 +176,67 @@ dl_expandspec(filespec) char vmsspec[NAM$C_MAXRSS], defspec[NAM$C_MAXRSS]; size_t deflen; vmssts sts; + dMY_CXT; tovmsspec(filespec,vmsspec); - dlfab.fab$l_fna = vmsspec; - dlfab.fab$b_fns = strlen(vmsspec); - dlfab.fab$l_dna = 0; - dlfab.fab$b_dns = 0; - DLDEBUG(1,fprintf(stderr,"dl_expand_filespec(%s):\n",vmsspec)); + dl_fab.fab$l_fna = vmsspec; + dl_fab.fab$b_fns = strlen(vmsspec); + dl_fab.fab$l_dna = 0; + dl_fab.fab$b_dns = 0; + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_expand_filespec(%s):\n",vmsspec)); /* On the first pass, just parse the specification string */ - dlnam.nam$b_nop = NAM$M_SYNCHK; - sts = sys$parse(&dlfab); - DLDEBUG(2,fprintf(stderr,"\tSYNCHK sys$parse = %d\n",sts)); + dl_nam.nam$b_nop = NAM$M_SYNCHK; + sts = sys$parse(&dl_fab); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tSYNCHK sys$parse = %d\n",sts)); if (!(sts & 1)) { - dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); - ST(0) = &sv_undef; + dl_set_error(dl_fab.fab$l_sts,dl_fab.fab$l_stv); + ST(0) = &PL_sv_undef; } else { /* Now set up a default spec - everything but the name */ - deflen = dlnam.nam$l_name - dlesa; - memcpy(defspec,dlesa,deflen); - memcpy(defspec+deflen,dlnam.nam$l_type, - dlnam.nam$b_type + dlnam.nam$b_ver); - deflen += dlnam.nam$b_type + dlnam.nam$b_ver; - memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name); - DLDEBUG(2,fprintf(stderr,"\tsplit filespec: name = %.*s, default = %.*s\n", - dlnam.nam$b_name,vmsspec,deflen,defspec)); + deflen = dl_nam.nam$l_name - dl_esa; + memcpy(defspec,dl_esa,deflen); + memcpy(defspec+deflen,dl_nam.nam$l_type, + dl_nam.nam$b_type + dl_nam.nam$b_ver); + deflen += dl_nam.nam$b_type + dl_nam.nam$b_ver; + memcpy(vmsspec,dl_nam.nam$l_name,dl_nam.nam$b_name); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsplit filespec: name = %.*s, default = %.*s\n", + dl_nam.nam$b_name,vmsspec,deflen,defspec)); /* . . . and go back to expand it */ - dlnam.nam$b_nop = 0; - dlfab.fab$l_dna = defspec; - dlfab.fab$b_dns = deflen; - dlfab.fab$b_fns = dlnam.nam$b_name; - sts = sys$parse(&dlfab); - DLDEBUG(2,fprintf(stderr,"\tname/default sys$parse = %d\n",sts)); + dl_nam.nam$b_nop = 0; + dl_fab.fab$l_dna = defspec; + dl_fab.fab$b_dns = deflen; + dl_fab.fab$b_fns = dl_nam.nam$b_name; + sts = sys$parse(&dl_fab); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tname/default sys$parse = %d\n",sts)); if (!(sts & 1)) { - dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); - ST(0) = &sv_undef; + dl_set_error(dl_fab.fab$l_sts,dl_fab.fab$l_stv); + ST(0) = &PL_sv_undef; } else { /* Now find the actual file */ - sts = sys$search(&dlfab); - DLDEBUG(2,fprintf(stderr,"\tsys$search = %d\n",sts)); - if (!(sts & 1) && sts != RMS$_FNF) { - dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); - ST(0) = &sv_undef; + sts = sys$search(&dl_fab); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$search = %d\n",sts)); + if (!(sts & 1)) { + dl_set_error(dl_fab.fab$l_sts,dl_fab.fab$l_stv); + ST(0) = &PL_sv_undef; } else { - ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); - DLDEBUG(1,fprintf(stderr,"\tresult = \\%.*s\\\n", - dlnam.nam$b_rsl,dlnam.nam$l_rsa)); + ST(0) = sv_2mortal(newSVpvn(dl_nam.nam$l_rsa,dl_nam.nam$b_rsl)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "\tresult = \\%.*s\\\n", + dl_nam.nam$b_rsl,dl_nam.nam$l_rsa)); } } } void -dl_load_file(filespec) - char * filespec - CODE: +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + dTHX; + dMY_CXT; char vmsspec[NAM$C_MAXRSS]; - AV *reqAV; SV *reqSV, **reqSVhndl; STRLEN deflen; struct dsc$descriptor_s @@ -208,18 +249,22 @@ dl_load_file(filespec) } namlst[2] = {{0,FSCN$_NAME,0},{0,0,0}}; struct libref *dlptr; vmssts sts, failed = 0; - void *entry; + void (*entry)(); + CODE: - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n",filespec)); - specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); + specdsc.dsc$a_pointer = tovmsspec(filename,vmsspec); specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer); - DLDEBUG(2,fprintf(stderr,"\tVMS-ified filespec is %s\n", + if (specdsc.dsc$w_length == 0) { /* undef in, empty out */ + XSRETURN_EMPTY; + } + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tVMS-ified filename is %s\n", specdsc.dsc$a_pointer)); - New(7901,dlptr,1,struct libref); + Newx(dlptr,1,struct libref); dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T; dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S; sts = sys$filescan(&specdsc,namlst,0); - DLDEBUG(2,fprintf(stderr,"\tsys$filescan: returns %d, name is %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$filescan: returns %d, name is %.*s\n", sts,namlst[0].len,namlst[0].string)); if (!(sts & 1)) { failed = 1; @@ -229,29 +274,27 @@ dl_load_file(filespec) dlptr->name.dsc$w_length = namlst[0].len; dlptr->name.dsc$a_pointer = savepvn(namlst[0].string,namlst[0].len); dlptr->defspec.dsc$w_length = specdsc.dsc$w_length - namlst[0].len; - dlptr->defspec.dsc$a_pointer = safemalloc(dlptr->defspec.dsc$w_length + 1); + Newx(dlptr->defspec.dsc$a_pointer, dlptr->defspec.dsc$w_length + 1, char); deflen = namlst[0].string - specdsc.dsc$a_pointer; memcpy(dlptr->defspec.dsc$a_pointer,specdsc.dsc$a_pointer,deflen); memcpy(dlptr->defspec.dsc$a_pointer + deflen, namlst[0].string + namlst[0].len, dlptr->defspec.dsc$w_length - deflen); - DLDEBUG(2,fprintf(stderr,"\tlibref = name: %s, defspec: %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlibref = name: %s, defspec: %.*s\n", dlptr->name.dsc$a_pointer, dlptr->defspec.dsc$w_length, dlptr->defspec.dsc$a_pointer)); - if (!(reqAV = GvAV(gv_fetchpv("DynaLoader::dl_require_symbols", - FALSE,SVt_PVAV))) - || !(reqSVhndl = av_fetch(reqAV,0,FALSE)) || !(reqSV = *reqSVhndl)) { - DLDEBUG(2,fprintf(stderr,"\t@dl_require_symbols empty, returning untested libref\n")); + if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) { + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\t@dl_require_symbols empty, returning untested libref\n")); } else { symdsc.dsc$w_length = SvCUR(reqSV); symdsc.dsc$a_pointer = SvPVX(reqSV); - DLDEBUG(2,fprintf(stderr,"\t$dl_require_symbols[0] = %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\t$dl_require_symbols[0] = %.*s\n", symdsc.dsc$w_length, symdsc.dsc$a_pointer)); - sts = lib$find_image_symbol(&(dlptr->name),&symdsc, + sts = my_find_image_symbol(&(dlptr->name),&symdsc, &entry,&(dlptr->defspec)); - DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts)); if (!(sts&1)) { failed = 1; dl_set_error(sts,0); @@ -263,10 +306,10 @@ dl_load_file(filespec) Safefree(dlptr->name.dsc$a_pointer); Safefree(dlptr->defspec.dsc$a_pointer); Safefree(dlptr); - ST(0) = &sv_undef; + ST(0) = &PL_sv_undef; } else { - ST(0) = sv_2mortal(newSViv((IV) dlptr)); + ST(0) = sv_2mortal(newSViv(PTR2IV(dlptr))); } @@ -281,19 +324,19 @@ dl_find_symbol(librefptr,symname) void (*entry)(); vmssts sts; - DLDEBUG(1,fprintf(stderr,"dl_find_dymbol(%.*s,%.*s):\n", + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_find_symbol(%.*s,%.*s):\n", thislib.name.dsc$w_length, thislib.name.dsc$a_pointer, symdsc.dsc$w_length,symdsc.dsc$a_pointer)); - sts = lib$find_image_symbol(&(thislib.name),&symdsc, - &entry,&(thislib.defspec)); - DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); - DLDEBUG(2,fprintf(stderr,"\tentry point is %d\n", + sts = my_find_image_symbol(&(thislib.name),&symdsc, + &entry,&(thislib.defspec)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tentry point is %d\n", (unsigned long int) entry)); if (!(sts & 1)) { dl_set_error(sts,0); - ST(0) = &sv_undef; + ST(0) = &PL_sv_undef; } - else ST(0) = sv_2mortal(newSViv((IV) entry)); + else ST(0) = sv_2mortal(newSViv(PTR2IV(entry))); void @@ -307,17 +350,21 @@ void dl_install_xsub(perl_name, symref, filename="$Package") char * perl_name void * symref - char * filename + const 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_flags(perl_name, + (void(*)(pTHX_ CV *))symref, + filename, NULL, + XS_DYNAMIC_FILENAME))); char * dl_error() CODE: - RETVAL = LastError ; + dMY_CXT; + RETVAL = dl_last_error ; OUTPUT: RETVAL