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