ext/VMS-DCLsym/DCLsym.xs

   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       EXTEND(sp,2);  /* just in case we're at the end of the stack */
  48       if (tbltype == LIB$K_CLI_LOCAL_SYM)
  49           PUSHs(sv_2mortal(newSVpv("LOCAL",5)));
  50       else
  51           PUSHs(sv_2mortal(newSVpv("GLOBAL",6)));
  52       _ckvmssts(lib$sfree1_dd(&valdsc));
  53     }
  54     else {
  55       /* error - we'll return an empty list */
  56       switch (retsts) {
  57         case LIB$_NOSUCHSYM:
  58           break;   /* nobody home */;
  59         case LIB$_INVSYMNAM:   /* user errors; set errno return undef */
  60         case LIB$_INSCLIMEM:
  61         case LIB$_NOCLI:
  62           set_errno(EVMSERR);
  63           set_vaxc_errno(retsts);
  64           break;
  65         default:  /* bail out */
  66           { _ckvmssts(retsts); }
  67       }
  68     }
  69   }
  70
  71
  72 void
  73 _setsym(name,val,typestr="LOCAL")
  74   SV *  name
  75   SV *  val
  76   char *        typestr
  77   CODE:
  78   {
  79     struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
  80                             valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
  81     STRLEN slen;
  82     int type;
  83     unsigned long int retsts;
  84     SETERRNO(0,SS$_NORMAL);
  85     if (!name || !val) {
  86       SETERRNO(EINVAL,LIB$_INVARG);
  87       XSRETURN_UNDEF;
  88     }
  89     namdsc.dsc$a_pointer = SvPV(name,slen);
  90     namdsc.dsc$w_length = (unsigned short int) slen;
  91     valdsc.dsc$a_pointer = SvPV(val,slen);
  92     valdsc.dsc$w_length = (unsigned short int) slen;
  93     type = strNE(typestr,"GLOBAL") ?
  94               LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM;
  95     retsts = lib$set_symbol(&namdsc,&valdsc,&type);
  96     if (retsts & 1) { XSRETURN_YES; }
  97     else {
  98       switch (retsts) {
  99         case LIB$_AMBSYMDEF:  /* user errors; set errno and return */
 100         case LIB$_INSCLIMEM:
 101         case LIB$_INVSYMNAM:
 102         case LIB$_NOCLI:
 103           set_errno(EVMSERR);
 104           set_vaxc_errno(retsts);
 105           XSRETURN_NO;
 106           break;  /* NOTREACHED */
 107         default:  /* bail out */
 108           { _ckvmssts(retsts); }
 109       }
 110     }
 111   }
 112
 113
 114 void
 115 _delsym(name,typestr="LOCAL")
 116   SV *  name
 117   char *        typestr
 118   CODE:
 119   {
 120     struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 121     STRLEN slen;
 122     int type;
 123     unsigned long int retsts;
 124     SETERRNO(0,SS$_NORMAL);
 125     if (!name || !typestr) {
 126       SETERRNO(EINVAL,LIB$_INVARG);
 127       XSRETURN_UNDEF;
 128     }
 129     namdsc.dsc$a_pointer = SvPV(name,slen);
 130     namdsc.dsc$w_length = (unsigned short int) slen;
 131     type = strNE(typestr,"GLOBAL") ?
 132               LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM;
 133     retsts = lib$delete_symbol(&namdsc,&type);
 134     if (retsts & 1) { XSRETURN_YES; }
 135     else {
 136       switch (retsts) {
 137         case LIB$_INVSYMNAM:  /* user errors; set errno and return */
 138         case LIB$_NOCLI:
 139         case LIB$_NOSUCHSYM:
 140           set_errno(EVMSERR);
 141           set_vaxc_errno(retsts);
 142           XSRETURN_NO;
 143           break;  /* NOTREACHED */
 144         default:  /* bail out */
 145           { _ckvmssts(retsts); }
 146       }
 147     }
 148   }
 149