Commit | Line | Data |
5f05dabc |
1 | /* VMS::DCLsym - manipulate DCL symbols |
2 | * |
3 | * Version: 1.0 |
bd3fa61c |
4 | * Author: Charles Bailey bailey@newman.upenn.edu |
5f05dabc |
5 | * Revised: 17-Aug-1995 |
6 | * |
7 | * |
8 | * Revision History: |
9 | * |
bd3fa61c |
10 | * 1.0 17-Aug-1995 Charles Bailey bailey@newman.upenn.edu |
5f05dabc |
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 { |
6b88bc9c |
57 | ST(0) = &PL_sv_undef; /* error - we're returning undef, if anything */ |
5f05dabc |
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 | |