home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / vms / ext / DCLsym / DCLsym.xs < prev    next >
Text File  |  1999-07-20  |  4KB  |  152 lines
  1. /* VMS::DCLsym - manipulate DCL symbols
  2.  *
  3.  * Version:  1.0
  4.  * Author:   Charles Bailey  bailey@newman.upenn.edu
  5.  * Revised:  17-Aug-1995
  6.  *
  7.  *
  8.  * Revision History:
  9.  * 
  10.  * 1.0  17-Aug-1995  Charles Bailey  bailey@newman.upenn.edu
  11.  *      original production version
  12.  */
  13.  
  14. #include <descrip.h>
  15. #include <lib$routines.h>
  16. #include <libclidef.h>
  17. #include <libdef.h>
  18. #include <ssdef.h>
  19. #include "EXTERN.h"
  20. #include "perl.h"
  21. #include "XSUB.h"
  22.  
  23. MODULE = VMS::DCLsym  PACKAGE = VMS::DCLsym
  24.  
  25. void
  26. _getsym(name)
  27.   SV *    name
  28.   PPCODE:
  29.   {
  30.     struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
  31.                             valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
  32.     STRLEN namlen;
  33.     int tbltype;
  34.     unsigned long int retsts;
  35.     SETERRNO(0,SS$_NORMAL);
  36.     if (!name) {
  37.       PUSHs(sv_newmortal());
  38.       SETERRNO(EINVAL,LIB$_INVARG);
  39.       return;
  40.     }
  41.     namdsc.dsc$a_pointer = SvPV(name,namlen);
  42.     namdsc.dsc$w_length = (unsigned short int) namlen;
  43.     retsts = lib$get_symbol(&namdsc,&valdsc,0,&tbltype);
  44.     if (retsts & 1) {
  45.       PUSHs(sv_2mortal(newSVpv(valdsc.dsc$w_length ? 
  46.                                valdsc.dsc$a_pointer : "",valdsc.dsc$w_length)));
  47.       if (GIMME) {
  48.         EXTEND(sp,2);  /* just in case we're at the end of the stack */
  49.         if (tbltype == LIB$K_CLI_LOCAL_SYM)
  50.           PUSHs(sv_2mortal(newSVpv("LOCAL",5)));
  51.         else
  52.           PUSHs(sv_2mortal(newSVpv("GLOBAL",6)));
  53.       }
  54.       _ckvmssts(lib$sfree1_dd(&valdsc));
  55.     }
  56.     else {
  57.       ST(0) = &PL_sv_undef;  /* error - we're returning undef, if anything */
  58.       switch (retsts) {
  59.         case LIB$_NOSUCHSYM:
  60.           break;   /* nobody home */;
  61.         case LIB$_INVSYMNAM:   /* user errors; set errno return undef */
  62.         case LIB$_INSCLIMEM:
  63.         case LIB$_NOCLI:
  64.           set_errno(EVMSERR);
  65.           set_vaxc_errno(retsts);
  66.           break;
  67.         default:  /* bail out */
  68.           { _ckvmssts(retsts); }
  69.       }
  70.     }
  71.   }
  72.  
  73.  
  74. void
  75. _setsym(name,val,typestr="LOCAL")
  76.   SV *    name
  77.   SV *    val
  78.   char *    typestr
  79.   CODE:
  80.   {
  81.     struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
  82.                             valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
  83.     STRLEN slen;
  84.     int type;
  85.     unsigned long int retsts;
  86.     SETERRNO(0,SS$_NORMAL);
  87.     if (!name || !val) {
  88.       SETERRNO(EINVAL,LIB$_INVARG);
  89.       XSRETURN_UNDEF;
  90.     }
  91.     namdsc.dsc$a_pointer = SvPV(name,slen);
  92.     namdsc.dsc$w_length = (unsigned short int) slen;
  93.     valdsc.dsc$a_pointer = SvPV(val,slen);
  94.     valdsc.dsc$w_length = (unsigned short int) slen;
  95.     type = strNE(typestr,"GLOBAL") ?
  96.               LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM;
  97.     retsts = lib$set_symbol(&namdsc,&valdsc,&type);
  98.     if (retsts & 1) { XSRETURN_YES; }
  99.     else {
  100.       switch (retsts) {
  101.         case LIB$_AMBSYMDEF:  /* user errors; set errno and return */
  102.         case LIB$_INSCLIMEM:
  103.         case LIB$_INVSYMNAM:
  104.         case LIB$_NOCLI:
  105.           set_errno(EVMSERR);
  106.           set_vaxc_errno(retsts);
  107.           XSRETURN_NO;
  108.           break;  /* NOTREACHED */
  109.         default:  /* bail out */
  110.           { _ckvmssts(retsts); }
  111.       }
  112.     }
  113.   }
  114.  
  115.  
  116. void
  117. _delsym(name,typestr="LOCAL")
  118.   SV *    name
  119.   char *    typestr
  120.   CODE:
  121.   {
  122.     struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
  123.     STRLEN slen;
  124.     int type;
  125.     unsigned long int retsts;
  126.     SETERRNO(0,SS$_NORMAL);
  127.     if (!name || !typestr) {
  128.       SETERRNO(EINVAL,LIB$_INVARG);
  129.       XSRETURN_UNDEF;
  130.     }
  131.     namdsc.dsc$a_pointer = SvPV(name,slen);
  132.     namdsc.dsc$w_length = (unsigned short int) slen;
  133.     type = strNE(typestr,"GLOBAL") ?
  134.               LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM;
  135.     retsts = lib$delete_symbol(&namdsc,&type);
  136.     if (retsts & 1) { XSRETURN_YES; }
  137.     else {
  138.       switch (retsts) {
  139.         case LIB$_INVSYMNAM:  /* user errors; set errno and return */
  140.         case LIB$_NOCLI:
  141.         case LIB$_NOSUCHSYM:
  142.           set_errno(EVMSERR);
  143.           set_vaxc_errno(retsts);
  144.           XSRETURN_NO;
  145.           break;  /* NOTREACHED */
  146.         default:  /* bail out */
  147.           { _ckvmssts(retsts); }
  148.       }
  149.     }
  150.   }
  151.  
  152.