home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / perl-5.003-base.tgz / perl-5.003-base.tar / fsf / perl / ext / DynaLoader / dl_vms.xs < prev    next >
Text File  |  1996-01-22  |  13KB  |  355 lines
  1. /* dl_vms.xs
  2.  * 
  3.  * Platform:  OpenVMS, VAX or AXP
  4.  * Author:    Charles Bailey  bailey@genetics.upenn.edu
  5.  * Revised:   12-Dec-1994
  6.  *
  7.  *                           Implementation Note
  8.  *     This section is added as an aid to users and DynaLoader developers, in
  9.  * order to clarify the process of dynamic linking under VMS.
  10.  *     dl_vms.xs uses the supported VMS dynamic linking call, which allows
  11.  * a running program to map an arbitrary file of executable code and call
  12.  * routines within that file.  This is done via the VMS RTL routine
  13.  * lib$find_image_symbol, whose calling sequence is as follows:
  14.  *   status = lib$find_image_symbol(imgname,symname,symval,defspec);
  15.  *   where
  16.  *     status  = a standard VMS status value (unsigned long int)
  17.  *     imgname = a fixed-length string descriptor, passed by
  18.  *               reference, containing the NAME ONLY of the image
  19.  *               file to be mapped.  An attempt will be made to
  20.  *               translate this string as a logical name, so it may
  21.  *               not contain any characters which are not allowed in
  22.  *               logical names.  If no translation is found, imgname
  23.  *               is used directly as the name of the image file.
  24.  *     symname = a fixed-length string descriptor, passed by
  25.  *               reference, containing the name of the routine
  26.  *               to be located.
  27.  *     symval  = an unsigned long int, passed by reference, into
  28.  *               which is written the entry point address of the
  29.  *               routine whose name is specified in symname.
  30.  *     defspec = a fixed-length string descriptor, passed by
  31.  *               reference, containing a default file specification
  32.  *               whichis used to fill in any missing parts of the
  33.  *               image file specification after the imgname argument
  34.  *               is processed.
  35.  * In order to accommodate the handling of the imgname argument, the routine
  36.  * dl_expandspec() is provided for use by perl code (e.g. dl_findfile)
  37.  * which wants to see what image file lib$find_image_symbol would use if
  38.  * it were passed a given file specification.  The file specification passed
  39.  * to dl_expandspec() and dl_load_file() can be partial or complete, and can
  40.  * use VMS or Unix syntax; these routines perform the necessary conversions.
  41.  *    In general, writers of perl extensions need only conform to the
  42.  * procedures set out in the DynaLoader documentation, and let the details
  43.  * be taken care of by the routines here and in DynaLoader.pm.  If anyone
  44.  * comes across any incompatibilities, please let me know.  Thanks.
  45.  *
  46.  */
  47.  
  48. #include "EXTERN.h"
  49. #include "perl.h"
  50. #include "XSUB.h"
  51.  
  52. #include "dlutils.c"    /* dl_debug, LastError; SaveError not used  */
  53.  
  54. static AV *dl_require_symbols = Nullav;
  55.  
  56. /* N.B.:
  57.  * dl_debug and LastError are static vars; you'll need to deal
  58.  * with them appropriately if you need context independence
  59.  */
  60.  
  61. #include <descrip.h>
  62. #include <fscndef.h>
  63. #include <lib$routines.h>
  64. #include <rms.h>
  65. #include <ssdef.h>
  66. #include <starlet.h>
  67.  
  68. typedef unsigned long int vmssts;
  69.  
  70. struct libref {
  71.   struct dsc$descriptor_s name;
  72.   struct dsc$descriptor_s defspec;
  73. };
  74.  
  75. /* Static data for dl_expand_filespec() - This is static to save
  76.  * initialization on each call; if you need context-independence,
  77.  * just make these auto variables in dl_expandspec() and dl_load_file()
  78.  */
  79. static char dlesa[NAM$C_MAXRSS], dlrsa[NAM$C_MAXRSS];
  80. static struct FAB dlfab;
  81. static struct NAM dlnam;
  82.  
  83. /* $PutMsg action routine - records error message in LastError */
  84. static vmssts
  85. copy_errmsg(msg,unused)
  86.     struct dsc$descriptor_s *   msg;
  87.     vmssts  unused;
  88. {
  89.     if (*(msg->dsc$a_pointer) == '%') { /* first line */
  90.       if (LastError)
  91.         strncpy((LastError = saferealloc(LastError,msg->dsc$w_length+1)),
  92.                  msg->dsc$a_pointer, msg->dsc$w_length);
  93.       else
  94.         strncpy((LastError = safemalloc(msg->dsc$w_length+1)),
  95.                  msg->dsc$a_pointer, msg->dsc$w_length);
  96.       LastError[msg->dsc$w_length] = '\0';
  97.     }
  98.     else { /* continuation line */
  99.       int errlen = strlen(LastError);
  100.       LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 2);
  101.       LastError[errlen] = '\n';  LastError[errlen+1] = '\0';
  102.       strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length);
  103.       LastError[errlen+msg->dsc$w_length+1] = '\0';
  104.     }
  105.     return 0;
  106. }
  107.  
  108. /* Use $PutMsg to retrieve error message for failure status code */
  109. static void
  110. dl_set_error(sts,stv)
  111.     vmssts  sts;
  112.     vmssts  stv;
  113. {
  114.     vmssts vec[3];
  115.  
  116.     vec[0] = stv ? 2 : 1;
  117.     vec[1] = sts;  vec[2] = stv;
  118.     _ckvmssts(sys$putmsg(vec,copy_errmsg,0,0));
  119. }
  120.  
  121. static unsigned int
  122. findsym_handler(void *sig, void *mech)
  123. {
  124.     unsigned long int myvec[8],args, *usig = (unsigned long int *) sig;
  125.     /* Be paranoid and assume signal vector passed in might be readonly */
  126.     myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1;
  127.     while (--args) myvec[args] = usig[args];
  128.     _ckvmssts(sys$putmsg(myvec,copy_errmsg,0,0));
  129.     DLDEBUG(2,fprintf(stderr,"findsym_handler: received\n\t%s\n",LastError));
  130.     return SS$_CONTINUE;
  131. }
  132.  
  133. /* wrapper for lib$find_image_symbol, so signalled errors can be saved
  134.  * for dl_error and then returned */
  135. static unsigned long int
  136. my_find_image_symbol(struct dsc$descriptor_s *imgname,
  137.                      struct dsc$descriptor_s *symname,
  138.                      void (**entry)(),
  139.                      struct dsc$descriptor_s *defspec)
  140. {
  141.   unsigned long int retsts;
  142.   VAXC$ESTABLISH(findsym_handler);
  143.   retsts = lib$find_image_symbol(imgname,symname,entry,defspec);
  144.   return retsts;
  145. }
  146.  
  147.  
  148. static void
  149. dl_private_init()
  150. {
  151.     dl_generic_private_init();
  152.     dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4);
  153.     /* Set up the static control blocks for dl_expand_filespec() */
  154.     dlfab = cc$rms_fab;
  155.     dlnam = cc$rms_nam;
  156.     dlfab.fab$l_nam = &dlnam;
  157.     dlnam.nam$l_esa = dlesa;
  158.     dlnam.nam$b_ess = sizeof dlesa;
  159.     dlnam.nam$l_rsa = dlrsa;
  160.     dlnam.nam$b_rss = sizeof dlrsa;
  161. }
  162. MODULE = DynaLoader PACKAGE = DynaLoader
  163.  
  164. BOOT:
  165.     (void)dl_private_init();
  166.  
  167. void
  168. dl_expandspec(filespec)
  169.     char *    filespec
  170.     CODE:
  171.     char vmsspec[NAM$C_MAXRSS], defspec[NAM$C_MAXRSS];
  172.     size_t deflen;
  173.     vmssts sts;
  174.  
  175.     tovmsspec(filespec,vmsspec);
  176.     dlfab.fab$l_fna = vmsspec;
  177.     dlfab.fab$b_fns = strlen(vmsspec);
  178.     dlfab.fab$l_dna = 0;
  179.     dlfab.fab$b_dns = 0;
  180.     DLDEBUG(1,fprintf(stderr,"dl_expand_filespec(%s):\n",vmsspec));
  181.     /* On the first pass, just parse the specification string */
  182.     dlnam.nam$b_nop = NAM$M_SYNCHK;
  183.     sts = sys$parse(&dlfab);
  184.     DLDEBUG(2,fprintf(stderr,"\tSYNCHK sys$parse = %d\n",sts));
  185.     if (!(sts & 1)) {
  186.       dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
  187.       ST(0) = &sv_undef;
  188.     }
  189.     else {
  190.       /* Now set up a default spec - everything but the name */
  191.       deflen = dlnam.nam$l_name - dlesa;
  192.       memcpy(defspec,dlesa,deflen);
  193.       memcpy(defspec+deflen,dlnam.nam$l_type,
  194.              dlnam.nam$b_type + dlnam.nam$b_ver);
  195.       deflen += dlnam.nam$b_type + dlnam.nam$b_ver;
  196.       memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name);
  197.       DLDEBUG(2,fprintf(stderr,"\tsplit filespec: name = %.*s, default = %.*s\n",
  198.                         dlnam.nam$b_name,vmsspec,deflen,defspec));
  199.       /* . . . and go back to expand it */
  200.       dlnam.nam$b_nop = 0;
  201.       dlfab.fab$l_dna = defspec;
  202.       dlfab.fab$b_dns = deflen;
  203.       dlfab.fab$b_fns = dlnam.nam$b_name;
  204.       sts = sys$parse(&dlfab);
  205.       DLDEBUG(2,fprintf(stderr,"\tname/default sys$parse = %d\n",sts));
  206.       if (!(sts & 1)) {
  207.         dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
  208.         ST(0) = &sv_undef;
  209.       }
  210.       else {
  211.         /* Now find the actual file */
  212.         sts = sys$search(&dlfab);
  213.         DLDEBUG(2,fprintf(stderr,"\tsys$search = %d\n",sts));
  214.         if (!(sts & 1)) {
  215.           dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
  216.           ST(0) = &sv_undef;
  217.         }
  218.         else {
  219.           ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl));
  220.           DLDEBUG(1,fprintf(stderr,"\tresult = \\%.*s\\\n",
  221.                             dlnam.nam$b_rsl,dlnam.nam$l_rsa));
  222.         }
  223.       }
  224.     }
  225.  
  226. void
  227. dl_load_file(filespec)
  228.     char *    filespec
  229.     CODE:
  230.     char vmsspec[NAM$C_MAXRSS];
  231.     SV *reqSV, **reqSVhndl;
  232.     STRLEN deflen;
  233.     struct dsc$descriptor_s
  234.       specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
  235.       symdsc  = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
  236.     struct fscnlst {
  237.       unsigned short int len;
  238.       unsigned short int code;
  239.       char *string;
  240.     }  namlst[2] = {{0,FSCN$_NAME,0},{0,0,0}};
  241.     struct libref *dlptr;
  242.     vmssts sts, failed = 0;
  243.     void (*entry)();
  244.  
  245.     DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n",filespec));
  246.     specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec);
  247.     specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer);
  248.     DLDEBUG(2,fprintf(stderr,"\tVMS-ified filespec is %s\n",
  249.                       specdsc.dsc$a_pointer));
  250.     New(7901,dlptr,1,struct libref);
  251.     dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T;
  252.     dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S;
  253.     sts = sys$filescan(&specdsc,namlst,0);
  254.     DLDEBUG(2,fprintf(stderr,"\tsys$filescan: returns %d, name is %.*s\n",
  255.                       sts,namlst[0].len,namlst[0].string));
  256.     if (!(sts & 1)) {
  257.       failed = 1;
  258.       dl_set_error(sts,0);
  259.     }
  260.     else {
  261.       dlptr->name.dsc$w_length = namlst[0].len;
  262.       dlptr->name.dsc$a_pointer = savepvn(namlst[0].string,namlst[0].len);
  263.       dlptr->defspec.dsc$w_length = specdsc.dsc$w_length - namlst[0].len;
  264.       dlptr->defspec.dsc$a_pointer = safemalloc(dlptr->defspec.dsc$w_length + 1);
  265.       deflen = namlst[0].string - specdsc.dsc$a_pointer; 
  266.       memcpy(dlptr->defspec.dsc$a_pointer,specdsc.dsc$a_pointer,deflen);
  267.       memcpy(dlptr->defspec.dsc$a_pointer + deflen,
  268.              namlst[0].string + namlst[0].len,
  269.              dlptr->defspec.dsc$w_length - deflen);
  270.       DLDEBUG(2,fprintf(stderr,"\tlibref = name: %s, defspec: %.*s\n",
  271.                         dlptr->name.dsc$a_pointer,
  272.                         dlptr->defspec.dsc$w_length,
  273.                         dlptr->defspec.dsc$a_pointer));
  274.       if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) {
  275.         DLDEBUG(2,fprintf(stderr,"\t@dl_require_symbols empty, returning untested libref\n"));
  276.       }
  277.       else {
  278.         symdsc.dsc$w_length = SvCUR(reqSV);
  279.         symdsc.dsc$a_pointer = SvPVX(reqSV);
  280.         DLDEBUG(2,fprintf(stderr,"\t$dl_require_symbols[0] = %.*s\n",
  281.                           symdsc.dsc$w_length, symdsc.dsc$a_pointer));
  282.         sts = my_find_image_symbol(&(dlptr->name),&symdsc,
  283.                                     &entry,&(dlptr->defspec));
  284.         DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts));
  285.         if (!(sts&1)) {
  286.           failed = 1;
  287.           dl_set_error(sts,0);
  288.         }
  289.       }
  290.     }
  291.  
  292.     if (failed) {
  293.       Safefree(dlptr->name.dsc$a_pointer);
  294.       Safefree(dlptr->defspec.dsc$a_pointer);
  295.       Safefree(dlptr);
  296.       ST(0) = &sv_undef;
  297.     }
  298.     else {
  299.       ST(0) = sv_2mortal(newSViv((IV) dlptr));
  300.     }
  301.  
  302.  
  303. void
  304. dl_find_symbol(librefptr,symname)
  305.     void *    librefptr
  306.     SV *    symname
  307.     CODE:
  308.     struct libref thislib = *((struct libref *)librefptr);
  309.     struct dsc$descriptor_s
  310.       symdsc = {SvCUR(symname),DSC$K_DTYPE_T,DSC$K_CLASS_S,SvPVX(symname)};
  311.     void (*entry)();
  312.     vmssts sts;
  313.  
  314.     DLDEBUG(1,fprintf(stderr,"dl_find_dymbol(%.*s,%.*s):\n",
  315.                       thislib.name.dsc$w_length, thislib.name.dsc$a_pointer,
  316.                       symdsc.dsc$w_length,symdsc.dsc$a_pointer));
  317.     sts = my_find_image_symbol(&(thislib.name),&symdsc,
  318.                                &entry,&(thislib.defspec));
  319.     DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts));
  320.     DLDEBUG(2,fprintf(stderr,"\tentry point is %d\n",
  321.                       (unsigned long int) entry));
  322.     if (!(sts & 1)) {
  323.       /* error message already saved by findsym_handler */
  324.       ST(0) = &sv_undef;
  325.     }
  326.     else ST(0) = sv_2mortal(newSViv((IV) entry));
  327.  
  328.  
  329. void
  330. dl_undef_symbols()
  331.     PPCODE:
  332.  
  333.  
  334. # These functions should not need changing on any platform:
  335.  
  336. void
  337. dl_install_xsub(perl_name, symref, filename="$Package")
  338.     char *    perl_name
  339.     void *    symref 
  340.     char *    filename
  341.     CODE:
  342.     DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
  343.         perl_name, symref));
  344.     ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
  345.  
  346.  
  347. char *
  348. dl_error()
  349.     CODE:
  350.     RETVAL = LastError ;
  351.     OUTPUT:
  352.       RETVAL
  353.  
  354. # end.
  355.