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       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