home *** CD-ROM | disk | FTP | other *** search
/ OpenStep 4.2J (Developer) / os42jdev.iso / NextDeveloper / Source / GNU / perl / Perl / ext / DynaLoader / dl_vms.xs < prev    next >
Encoding:
Text File  |  1995-02-14  |  11.3 KB  |  325 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. /* N.B.:
  54.  * dl_debug and LastError are static vars; you'll need to deal
  55.  * with them appropriately if you need context independence
  56.  */
  57.  
  58. #include <descrip.h>
  59. #include <fscndef.h>
  60. #include <lib$routines.h>
  61. #include <rms.h>
  62. #include <ssdef.h>
  63. #include <starlet.h>
  64.  
  65. typedef unsigned long int vmssts;
  66.  
  67. struct libref {
  68.   struct dsc$descriptor_s name;
  69.   struct dsc$descriptor_s defspec;
  70. };
  71.  
  72. /* Static data for dl_expand_filespec() - This is static to save
  73.  * initialization on each call; if you need context-independence,
  74.  * just make these auto variables in dl_expandspec() and dl_load_file()
  75.  */
  76. static char dlesa[NAM$C_MAXRSS], dlrsa[NAM$C_MAXRSS];
  77. static struct FAB dlfab;
  78. static struct NAM dlnam;
  79.  
  80. /* $PutMsg action routine - records error message in LastError */
  81. static vmssts
  82. copy_errmsg(msg,unused)
  83.     struct dsc$descriptor_s *   msg;
  84.     vmssts  unused;
  85. {
  86.     if (*(msg->dsc$a_pointer) == '%') { /* first line */
  87.       if (LastError)
  88.         strncpy((LastError = saferealloc(LastError,msg->dsc$w_length)),
  89.                  msg->dsc$a_pointer, msg->dsc$w_length);
  90.       else
  91.         strncpy((LastError = safemalloc(msg->dsc$w_length)),
  92.                  msg->dsc$a_pointer, msg->dsc$w_length);
  93.       return 0;
  94.     }
  95.     else { /* continuation line */
  96.       int errlen = strlen(LastError);
  97.       LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 1);
  98.       LastError[errlen] = '\n';  LastError[errlen+1] = '\0';
  99.       strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length);
  100.     }
  101. }
  102.  
  103. /* Use $PutMsg to retrieve error message for failure status code */
  104. static void
  105. dl_set_error(sts,stv)
  106.     vmssts  sts;
  107.     vmssts  stv;
  108. {
  109.     vmssts vec[3];
  110.  
  111.     vec[0] = stv ? 2 : 1;
  112.     vec[1] = sts;  vec[2] = stv;
  113.     _ckvmssts(sys$putmsg(vec,copy_errmsg,0,0));
  114. }
  115.  
  116. static void
  117. dl_private_init()
  118. {
  119.     dl_generic_private_init();
  120.     /* Set up the static control blocks for dl_expand_filespec() */
  121.     dlfab = cc$rms_fab;
  122.     dlnam = cc$rms_nam;
  123.     dlfab.fab$l_nam = &dlnam;
  124.     dlnam.nam$l_esa = dlesa;
  125.     dlnam.nam$b_ess = sizeof dlesa;
  126.     dlnam.nam$l_rsa = dlrsa;
  127.     dlnam.nam$b_rss = sizeof dlrsa;
  128. }
  129. MODULE = DynaLoader PACKAGE = DynaLoader
  130.  
  131. BOOT:
  132.     (void)dl_private_init();
  133.  
  134. void
  135. dl_expandspec(filespec)
  136.     char *    filespec
  137.     CODE:
  138.     char vmsspec[NAM$C_MAXRSS], defspec[NAM$C_MAXRSS];
  139.     size_t deflen;
  140.     vmssts sts;
  141.  
  142.     tovmsspec(filespec,vmsspec);
  143.     dlfab.fab$l_fna = vmsspec;
  144.     dlfab.fab$b_fns = strlen(vmsspec);
  145.     dlfab.fab$l_dna = 0;
  146.     dlfab.fab$b_dns = 0;
  147.     DLDEBUG(1,fprintf(stderr,"dl_expand_filespec(%s):\n",vmsspec));
  148.     /* On the first pass, just parse the specification string */
  149.     dlnam.nam$b_nop = NAM$M_SYNCHK;
  150.     sts = sys$parse(&dlfab);
  151.     DLDEBUG(2,fprintf(stderr,"\tSYNCHK sys$parse = %d\n",sts));
  152.     if (!(sts & 1)) {
  153.       dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
  154.       ST(0) = &sv_undef;
  155.     }
  156.     else {
  157.       /* Now set up a default spec - everything but the name */
  158.       deflen = dlnam.nam$l_name - dlesa;
  159.       memcpy(defspec,dlesa,deflen);
  160.       memcpy(defspec+deflen,dlnam.nam$l_type,
  161.              dlnam.nam$b_type + dlnam.nam$b_ver);
  162.       deflen += dlnam.nam$b_type + dlnam.nam$b_ver;
  163.       memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name);
  164.       DLDEBUG(2,fprintf(stderr,"\tsplit filespec: name = %.*s, default = %.*s\n",
  165.                         dlnam.nam$b_name,vmsspec,deflen,defspec));
  166.       /* . . . and go back to expand it */
  167.       dlnam.nam$b_nop = 0;
  168.       dlfab.fab$l_dna = defspec;
  169.       dlfab.fab$b_dns = deflen;
  170.       dlfab.fab$b_fns = dlnam.nam$b_name;
  171.       sts = sys$parse(&dlfab);
  172.       DLDEBUG(2,fprintf(stderr,"\tname/default sys$parse = %d\n",sts));
  173.       if (!(sts & 1)) {
  174.         dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
  175.         ST(0) = &sv_undef;
  176.       }
  177.       else {
  178.         /* Now find the actual file */
  179.         sts = sys$search(&dlfab);
  180.         DLDEBUG(2,fprintf(stderr,"\tsys$search = %d\n",sts));
  181.         if (!(sts & 1) && sts != RMS$_FNF) {
  182.           dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
  183.           ST(0) = &sv_undef;
  184.         }
  185.         else {
  186.           ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl));
  187.           DLDEBUG(1,fprintf(stderr,"\tresult = \\%.*s\\\n",
  188.                             dlnam.nam$b_rsl,dlnam.nam$l_rsa));
  189.         }
  190.       }
  191.     }
  192.  
  193. void
  194. dl_load_file(filespec)
  195.     char *    filespec
  196.     CODE:
  197.     char vmsspec[NAM$C_MAXRSS];
  198.     AV *reqAV;
  199.     SV *reqSV, **reqSVhndl;
  200.     STRLEN deflen;
  201.     struct dsc$descriptor_s
  202.       specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
  203.       symdsc  = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
  204.     struct fscnlst {
  205.       unsigned short int len;
  206.       unsigned short int code;
  207.       char *string;
  208.     }  namlst[2] = {{0,FSCN$_NAME,0},{0,0,0}};
  209.     struct libref *dlptr;
  210.     vmssts sts, failed = 0;
  211.     void *entry;
  212.  
  213.     DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n",filespec));
  214.     specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec);
  215.     specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer);
  216.     DLDEBUG(2,fprintf(stderr,"\tVMS-ified filespec is %s\n",
  217.                       specdsc.dsc$a_pointer));
  218.     New(7901,dlptr,1,struct libref);
  219.     dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T;
  220.     dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S;
  221.     sts = sys$filescan(&specdsc,namlst,0);
  222.     DLDEBUG(2,fprintf(stderr,"\tsys$filescan: returns %d, name is %.*s\n",
  223.                       sts,namlst[0].len,namlst[0].string));
  224.     if (!(sts & 1)) {
  225.       failed = 1;
  226.       dl_set_error(sts,0);
  227.     }
  228.     else {
  229.       dlptr->name.dsc$w_length = namlst[0].len;
  230.       dlptr->name.dsc$a_pointer = savepvn(namlst[0].string,namlst[0].len);
  231.       dlptr->defspec.dsc$w_length = specdsc.dsc$w_length - namlst[0].len;
  232.       dlptr->defspec.dsc$a_pointer = safemalloc(dlptr->defspec.dsc$w_length + 1);
  233.       deflen = namlst[0].string - specdsc.dsc$a_pointer; 
  234.       memcpy(dlptr->defspec.dsc$a_pointer,specdsc.dsc$a_pointer,deflen);
  235.       memcpy(dlptr->defspec.dsc$a_pointer + deflen,
  236.              namlst[0].string + namlst[0].len,
  237.              dlptr->defspec.dsc$w_length - deflen);
  238.       DLDEBUG(2,fprintf(stderr,"\tlibref = name: %s, defspec: %.*s\n",
  239.                         dlptr->name.dsc$a_pointer,
  240.                         dlptr->defspec.dsc$w_length,
  241.                         dlptr->defspec.dsc$a_pointer));
  242.       if (!(reqAV = GvAV(gv_fetchpv("DynaLoader::dl_require_symbols",
  243.                                      FALSE,SVt_PVAV)))
  244.           || !(reqSVhndl = av_fetch(reqAV,0,FALSE)) || !(reqSV = *reqSVhndl)) {
  245.         DLDEBUG(2,fprintf(stderr,"\t@dl_require_symbols empty, returning untested libref\n"));
  246.       }
  247.       else {
  248.         symdsc.dsc$w_length = SvCUR(reqSV);
  249.         symdsc.dsc$a_pointer = SvPVX(reqSV);
  250.         DLDEBUG(2,fprintf(stderr,"\t$dl_require_symbols[0] = %.*s\n",
  251.                           symdsc.dsc$w_length, symdsc.dsc$a_pointer));
  252.         sts = lib$find_image_symbol(&(dlptr->name),&symdsc,
  253.                                     &entry,&(dlptr->defspec));
  254.         DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts));
  255.         if (!(sts&1)) {
  256.           failed = 1;
  257.           dl_set_error(sts,0);
  258.         }
  259.       }
  260.     }
  261.  
  262.     if (failed) {
  263.       Safefree(dlptr->name.dsc$a_pointer);
  264.       Safefree(dlptr->defspec.dsc$a_pointer);
  265.       Safefree(dlptr);
  266.       ST(0) = &sv_undef;
  267.     }
  268.     else {
  269.       ST(0) = sv_2mortal(newSViv((IV) dlptr));
  270.     }
  271.  
  272.  
  273. void
  274. dl_find_symbol(librefptr,symname)
  275.     void *    librefptr
  276.     SV *    symname
  277.     CODE:
  278.     struct libref thislib = *((struct libref *)librefptr);
  279.     struct dsc$descriptor_s
  280.       symdsc = {SvCUR(symname),DSC$K_DTYPE_T,DSC$K_CLASS_S,SvPVX(symname)};
  281.     void (*entry)();
  282.     vmssts sts;
  283.  
  284.     DLDEBUG(1,fprintf(stderr,"dl_find_dymbol(%.*s,%.*s):\n",
  285.                       thislib.name.dsc$w_length, thislib.name.dsc$a_pointer,
  286.                       symdsc.dsc$w_length,symdsc.dsc$a_pointer));
  287.     sts = lib$find_image_symbol(&(thislib.name),&symdsc,
  288.                                 &entry,&(thislib.defspec));
  289.     DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts));
  290.     DLDEBUG(2,fprintf(stderr,"\tentry point is %d\n",
  291.                       (unsigned long int) entry));
  292.     if (!(sts & 1)) {
  293.       dl_set_error(sts,0);
  294.       ST(0) = &sv_undef;
  295.     }
  296.     else ST(0) = sv_2mortal(newSViv((IV) entry));
  297.  
  298.  
  299. void
  300. dl_undef_symbols()
  301.     PPCODE:
  302.  
  303.  
  304. # These functions should not need changing on any platform:
  305.  
  306. void
  307. dl_install_xsub(perl_name, symref, filename="$Package")
  308.     char *    perl_name
  309.     void *    symref 
  310.     char *    filename
  311.     CODE:
  312.     DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
  313.         perl_name, symref));
  314.     ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
  315.  
  316.  
  317. char *
  318. dl_error()
  319.     CODE:
  320.     RETVAL = LastError ;
  321.     OUTPUT:
  322.       RETVAL
  323.  
  324. # end.
  325.