source: trunk/essentials/dev-lang/perl/vms/ext/DCLsym/DCLsym.xs@ 3184

Last change on this file since 3184 was 3181, checked in by bird, 19 years ago

perl 5.8.8
File size: 4.0 KB
Line 
1/* VMS::DCLsym - manipulate DCL symbols
2 *
3 * Version: 1.0
4 * Author: Charles Bailey [email protected]
5 * Revised: 17-Aug-1995
6 *
7 *
8 * Revision History:
9 *
10 * 1.0 17-Aug-1995 Charles Bailey [email protected]
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
23MODULE = VMS::DCLsym PACKAGE = VMS::DCLsym
24
25void
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
74void
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
116void
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
Note: See TracBrowser for help on using the repository browser.