Updated to Oct 31, 1995 version.
[p5sagit/p5-mst-13.2.git] / ext / DynaLoader / dl_vms.xs
index c6e58fb..3f46ffc 100644 (file)
@@ -50,6 +50,9 @@
 #include "XSUB.h"
 
 #include "dlutils.c"    /* dl_debug, LastError; SaveError not used  */
+
+static AV *dl_require_symbols = Nullav;
+
 /* N.B.:
  * dl_debug and LastError are static vars; you'll need to deal
  * with them appropriately if you need context independence
@@ -85,19 +88,21 @@ copy_errmsg(msg,unused)
 {
     if (*(msg->dsc$a_pointer) == '%') { /* first line */
       if (LastError)
-        strncpy((LastError = saferealloc(LastError,msg->dsc$w_length)),
+        strncpy((LastError = saferealloc(LastError,msg->dsc$w_length+1)),
                  msg->dsc$a_pointer, msg->dsc$w_length);
       else
-        strncpy((LastError = safemalloc(msg->dsc$w_length)),
+        strncpy((LastError = safemalloc(msg->dsc$w_length+1)),
                  msg->dsc$a_pointer, msg->dsc$w_length);
-      return 0;
+      LastError[msg->dsc$w_length] = '\0';
     }
     else { /* continuation line */
       int errlen = strlen(LastError);
-      LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 1);
+      LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 2);
       LastError[errlen] = '\n';  LastError[errlen+1] = '\0';
       strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length);
+      LastError[errlen+msg->dsc$w_length+1] = '\0';
     }
+    return 0;
 }
 
 /* Use $PutMsg to retrieve error message for failure status code */
@@ -113,10 +118,38 @@ dl_set_error(sts,stv)
     _ckvmssts(sys$putmsg(vec,copy_errmsg,0,0));
 }
 
+static unsigned int
+findsym_handler(void *sig, void *mech)
+{
+    unsigned long int myvec[8],args, *usig = (unsigned long int *) sig;
+    /* Be paranoid and assume signal vector passed in might be readonly */
+    myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1;
+    while (--args) myvec[args] = usig[args];
+    _ckvmssts(sys$putmsg(myvec,copy_errmsg,0,0));
+    DLDEBUG(2,fprintf(stderr,"findsym_handler: received\n\t%s\n",LastError));
+    return SS$_CONTINUE;
+}
+
+/* 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(findsym_handler);
+  retsts = lib$find_image_symbol(imgname,symname,entry,defspec);
+  return retsts;
+}
+
+
 static void
 dl_private_init()
 {
     dl_generic_private_init();
+    dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4);
     /* Set up the static control blocks for dl_expand_filespec() */
     dlfab = cc$rms_fab;
     dlnam = cc$rms_nam;
@@ -178,7 +211,7 @@ dl_expandspec(filespec)
         /* Now find the actual file */
         sts = sys$search(&dlfab);
         DLDEBUG(2,fprintf(stderr,"\tsys$search = %d\n",sts));
-        if (!(sts & 1) && sts != RMS$_FNF) {
+        if (!(sts & 1)) {
           dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
           ST(0) = &sv_undef;
         }
@@ -195,7 +228,6 @@ dl_load_file(filespec)
     char *     filespec
     CODE:
     char vmsspec[NAM$C_MAXRSS];
-    AV *reqAV;
     SV *reqSV, **reqSVhndl;
     STRLEN deflen;
     struct dsc$descriptor_s
@@ -208,7 +240,7 @@ dl_load_file(filespec)
     }  namlst[2] = {{0,FSCN$_NAME,0},{0,0,0}};
     struct libref *dlptr;
     vmssts sts, failed = 0;
-    void *entry;
+    void (*entry)();
 
     DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n",filespec));
     specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec);
@@ -239,9 +271,7 @@ dl_load_file(filespec)
                         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)) {
+      if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) {
         DLDEBUG(2,fprintf(stderr,"\t@dl_require_symbols empty, returning untested libref\n"));
       }
       else {
@@ -249,7 +279,7 @@ dl_load_file(filespec)
         symdsc.dsc$a_pointer = SvPVX(reqSV);
         DLDEBUG(2,fprintf(stderr,"\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));
         if (!(sts&1)) {
@@ -284,13 +314,13 @@ dl_find_symbol(librefptr,symname)
     DLDEBUG(1,fprintf(stderr,"dl_find_dymbol(%.*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));
+    sts = my_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",
                       (unsigned long int) entry));
     if (!(sts & 1)) {
-      dl_set_error(sts,0);
+      /* error message already saved by findsym_handler */
       ST(0) = &sv_undef;
     }
     else ST(0) = sv_2mortal(newSViv((IV) entry));