home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / ext / DynaLoader / dl_vms.xs < prev    next >
Text File  |  2000-02-27  |  13KB  |  368 lines
  1. /* dl_vms.xs
  2.  * 
  3.  * Platform:  OpenVMS, VAX or AXP
  4.  * Author:    Charles Bailey  bailey@newman.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. #if defined(VMS_WE_ARE_CASE_SENSITIVE)
  69. #define DL_CASE_SENSITIVE 1<<4
  70. #else
  71. #define DL_CASE_SENSITIVE 0
  72. #endif
  73.  
  74. typedef unsigned long int vmssts;
  75.  
  76. struct libref {
  77.   struct dsc$descriptor_s name;
  78.   struct dsc$descriptor_s defspec;
  79. };
  80.  
  81. /* Static data for dl_expand_filespec() - This is static to save
  82.  * initialization on each call; if you need context-independence,
  83.  * just make these auto variables in dl_expandspec() and dl_load_file()
  84.  */
  85. static char dlesa[NAM$C_MAXRSS], dlrsa[NAM$C_MAXRSS];
  86. static struct FAB dlfab;
  87. static struct NAM dlnam;
  88.  
  89. /* $PutMsg action routine - records error message in LastError */
  90. static vmssts
  91. copy_errmsg(msg,unused)
  92.     struct dsc$descriptor_s *   msg;
  93.     vmssts  unused;
  94. {
  95.     if (*(msg->dsc$a_pointer) == '%') { /* first line */
  96.       if (LastError)
  97.         strncpy((LastError = saferealloc(LastError,msg->dsc$w_length+1)),
  98.                  msg->dsc$a_pointer, msg->dsc$w_length);
  99.       else
  100.         strncpy((LastError = safemalloc(msg->dsc$w_length+1)),
  101.                  msg->dsc$a_pointer, msg->dsc$w_length);
  102.       LastError[msg->dsc$w_length] = '\0';
  103.     }
  104.     else { /* continuation line */
  105.       int errlen = strlen(LastError);
  106.       LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 2);
  107.       LastError[errlen] = '\n';  LastError[errlen+1] = '\0';
  108.       strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length);
  109.       LastError[errlen+msg->dsc$w_length+1] = '\0';
  110.     }
  111.     return 0;
  112. }
  113.  
  114. /* Use $PutMsg to retrieve error message for failure status code */
  115. static void
  116. dl_set_error(sts,stv)
  117.     vmssts  sts;
  118.     vmssts  stv;
  119. {
  120.     vmssts vec[3];
  121.     dTHX;
  122.  
  123.     vec[0] = stv ? 2 : 1;
  124.     vec[1] = sts;  vec[2] = stv;
  125.     _ckvmssts(sys$putmsg(vec,copy_errmsg,0,0));
  126. }
  127.  
  128. static unsigned int
  129. findsym_handler(void *sig, void *mech)
  130. {
  131.     dTHX;
  132.     unsigned long int myvec[8],args, *usig = (unsigned long int *) sig;
  133.     /* Be paranoid and assume signal vector passed in might be readonly */
  134.     myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1;
  135.     while (--args) myvec[args] = usig[args];
  136.     _ckvmssts(sys$putmsg(myvec,copy_errmsg,0,0));
  137.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "findsym_handler: received\n\t%s\n",LastError));
  138.     return SS$_CONTINUE;
  139. }
  140.  
  141. /* wrapper for lib$find_image_symbol, so signalled errors can be saved
  142.  * for dl_error and then returned */
  143. static unsigned long int
  144. my_find_image_symbol(struct dsc$descriptor_s *imgname,
  145.                      struct dsc$descriptor_s *symname,
  146.                      void (**entry)(),
  147.                      struct dsc$descriptor_s *defspec)
  148. {
  149.   unsigned long int retsts;
  150.   VAXC$ESTABLISH(findsym_handler);
  151.   retsts = lib$find_image_symbol(imgname,symname,entry,defspec,DL_CASE_SENSITIVE);
  152.   return retsts;
  153. }
  154.  
  155.  
  156. static void
  157. dl_private_init(pTHX)
  158. {
  159.     dl_generic_private_init(aTHX);
  160.     dl_require_symbols = get_av("DynaLoader::dl_require_symbols", 0x4);
  161.     /* Set up the static control blocks for dl_expand_filespec() */
  162.     dlfab = cc$rms_fab;
  163.     dlnam = cc$rms_nam;
  164.     dlfab.fab$l_nam = &dlnam;
  165.     dlnam.nam$l_esa = dlesa;
  166.     dlnam.nam$b_ess = sizeof dlesa;
  167.     dlnam.nam$l_rsa = dlrsa;
  168.     dlnam.nam$b_rss = sizeof dlrsa;
  169. }
  170. MODULE = DynaLoader PACKAGE = DynaLoader
  171.  
  172. BOOT:
  173.     (void)dl_private_init(aTHX);
  174.  
  175. void
  176. dl_expandspec(filespec)
  177.     char *    filespec
  178.     CODE:
  179.     char vmsspec[NAM$C_MAXRSS], defspec[NAM$C_MAXRSS];
  180.     size_t deflen;
  181.     vmssts sts;
  182.  
  183.     tovmsspec(filespec,vmsspec);
  184.     dlfab.fab$l_fna = vmsspec;
  185.     dlfab.fab$b_fns = strlen(vmsspec);
  186.     dlfab.fab$l_dna = 0;
  187.     dlfab.fab$b_dns = 0;
  188.     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_expand_filespec(%s):\n",vmsspec));
  189.     /* On the first pass, just parse the specification string */
  190.     dlnam.nam$b_nop = NAM$M_SYNCHK;
  191.     sts = sys$parse(&dlfab);
  192.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tSYNCHK sys$parse = %d\n",sts));
  193.     if (!(sts & 1)) {
  194.       dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
  195.       ST(0) = &PL_sv_undef;
  196.     }
  197.     else {
  198.       /* Now set up a default spec - everything but the name */
  199.       deflen = dlnam.nam$l_name - dlesa;
  200.       memcpy(defspec,dlesa,deflen);
  201.       memcpy(defspec+deflen,dlnam.nam$l_type,
  202.              dlnam.nam$b_type + dlnam.nam$b_ver);
  203.       deflen += dlnam.nam$b_type + dlnam.nam$b_ver;
  204.       memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name);
  205.       DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsplit filespec: name = %.*s, default = %.*s\n",
  206.                         dlnam.nam$b_name,vmsspec,deflen,defspec));
  207.       /* . . . and go back to expand it */
  208.       dlnam.nam$b_nop = 0;
  209.       dlfab.fab$l_dna = defspec;
  210.       dlfab.fab$b_dns = deflen;
  211.       dlfab.fab$b_fns = dlnam.nam$b_name;
  212.       sts = sys$parse(&dlfab);
  213.       DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tname/default sys$parse = %d\n",sts));
  214.       if (!(sts & 1)) {
  215.         dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
  216.         ST(0) = &PL_sv_undef;
  217.       }
  218.       else {
  219.         /* Now find the actual file */
  220.         sts = sys$search(&dlfab);
  221.         DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$search = %d\n",sts));
  222.         if (!(sts & 1)) {
  223.           dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
  224.           ST(0) = &PL_sv_undef;
  225.         }
  226.         else {
  227.           ST(0) = sv_2mortal(newSVpvn(dlnam.nam$l_rsa,dlnam.nam$b_rsl));
  228.           DLDEBUG(1,PerlIO_printf(Perl_debug_log, "\tresult = \\%.*s\\\n",
  229.                             dlnam.nam$b_rsl,dlnam.nam$l_rsa));
  230.         }
  231.       }
  232.     }
  233.  
  234. void
  235. dl_load_file(filespec, flags)
  236.     char *    filespec
  237.     int        flags
  238.     PREINIT:
  239.     dTHX;
  240.     char vmsspec[NAM$C_MAXRSS];
  241.     SV *reqSV, **reqSVhndl;
  242.     STRLEN deflen;
  243.     struct dsc$descriptor_s
  244.       specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
  245.       symdsc  = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
  246.     struct fscnlst {
  247.       unsigned short int len;
  248.       unsigned short int code;
  249.       char *string;
  250.     }  namlst[2] = {{0,FSCN$_NAME,0},{0,0,0}};
  251.     struct libref *dlptr;
  252.     vmssts sts, failed = 0;
  253.     void (*entry)();
  254.     CODE:
  255.  
  256.     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filespec,flags));
  257.     specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec);
  258.     specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer);
  259.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tVMS-ified filespec is %s\n",
  260.                       specdsc.dsc$a_pointer));
  261.     New(1399,dlptr,1,struct libref);
  262.     dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T;
  263.     dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S;
  264.     sts = sys$filescan(&specdsc,namlst,0);
  265.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$filescan: returns %d, name is %.*s\n",
  266.                       sts,namlst[0].len,namlst[0].string));
  267.     if (!(sts & 1)) {
  268.       failed = 1;
  269.       dl_set_error(sts,0);
  270.     }
  271.     else {
  272.       dlptr->name.dsc$w_length = namlst[0].len;
  273.       dlptr->name.dsc$a_pointer = savepvn(namlst[0].string,namlst[0].len);
  274.       dlptr->defspec.dsc$w_length = specdsc.dsc$w_length - namlst[0].len;
  275.       New(1097, dlptr->defspec.dsc$a_pointer, dlptr->defspec.dsc$w_length + 1, char);
  276.       deflen = namlst[0].string - specdsc.dsc$a_pointer; 
  277.       memcpy(dlptr->defspec.dsc$a_pointer,specdsc.dsc$a_pointer,deflen);
  278.       memcpy(dlptr->defspec.dsc$a_pointer + deflen,
  279.              namlst[0].string + namlst[0].len,
  280.              dlptr->defspec.dsc$w_length - deflen);
  281.       DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlibref = name: %s, defspec: %.*s\n",
  282.                         dlptr->name.dsc$a_pointer,
  283.                         dlptr->defspec.dsc$w_length,
  284.                         dlptr->defspec.dsc$a_pointer));
  285.       if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) {
  286.         DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\t@dl_require_symbols empty, returning untested libref\n"));
  287.       }
  288.       else {
  289.         symdsc.dsc$w_length = SvCUR(reqSV);
  290.         symdsc.dsc$a_pointer = SvPVX(reqSV);
  291.         DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\t$dl_require_symbols[0] = %.*s\n",
  292.                           symdsc.dsc$w_length, symdsc.dsc$a_pointer));
  293.         sts = my_find_image_symbol(&(dlptr->name),&symdsc,
  294.                                     &entry,&(dlptr->defspec));
  295.         DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts));
  296.         if (!(sts&1)) {
  297.           failed = 1;
  298.           dl_set_error(sts,0);
  299.         }
  300.       }
  301.     }
  302.  
  303.     if (failed) {
  304.       Safefree(dlptr->name.dsc$a_pointer);
  305.       Safefree(dlptr->defspec.dsc$a_pointer);
  306.       Safefree(dlptr);
  307.       ST(0) = &PL_sv_undef;
  308.     }
  309.     else {
  310.       ST(0) = sv_2mortal(newSViv(PTR2IV(dlptr)));
  311.     }
  312.  
  313.  
  314. void
  315. dl_find_symbol(librefptr,symname)
  316.     void *    librefptr
  317.     SV *    symname
  318.     CODE:
  319.     struct libref thislib = *((struct libref *)librefptr);
  320.     struct dsc$descriptor_s
  321.       symdsc = {SvCUR(symname),DSC$K_DTYPE_T,DSC$K_CLASS_S,SvPVX(symname)};
  322.     void (*entry)();
  323.     vmssts sts;
  324.  
  325.     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_find_dymbol(%.*s,%.*s):\n",
  326.                       thislib.name.dsc$w_length, thislib.name.dsc$a_pointer,
  327.                       symdsc.dsc$w_length,symdsc.dsc$a_pointer));
  328.     sts = my_find_image_symbol(&(thislib.name),&symdsc,
  329.                                &entry,&(thislib.defspec));
  330.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts));
  331.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tentry point is %d\n",
  332.                       (unsigned long int) entry));
  333.     if (!(sts & 1)) {
  334.       /* error message already saved by findsym_handler */
  335.       ST(0) = &PL_sv_undef;
  336.     }
  337.     else ST(0) = sv_2mortal(newSViv(PTR2IV(entry)));
  338.  
  339.  
  340. void
  341. dl_undef_symbols()
  342.     PPCODE:
  343.  
  344.  
  345. # These functions should not need changing on any platform:
  346.  
  347. void
  348. dl_install_xsub(perl_name, symref, filename="$Package")
  349.     char *    perl_name
  350.     void *    symref 
  351.     char *    filename
  352.     CODE:
  353.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
  354.         perl_name, symref));
  355.     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
  356.                       (void(*)(pTHX_ CV *))symref,
  357.                       filename)));
  358.  
  359.  
  360. char *
  361. dl_error()
  362.     CODE:
  363.     RETVAL = LastError ;
  364.     OUTPUT:
  365.       RETVAL
  366.  
  367. # end.
  368.