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 
150