Commit | Line | Data |
2ae00b68 |
1 | /* VMS::Stdio - VMS extensions to stdio routines |
748a9306 |
2 | * |
562a7b0c |
3 | * Version: 2.2 |
4 | * Author: Charles Bailey bailey@newman.upenn.edu |
5 | * Revised: 18-Jul-1998 |
748a9306 |
6 | * |
748a9306 |
7 | */ |
8 | |
9 | #include "EXTERN.h" |
10 | #include "perl.h" |
11 | #include "XSUB.h" |
2ae00b68 |
12 | #include <file.h> |
17f28c40 |
13 | #include <iodef.h> |
14 | #include <rms.h> |
15 | #include <starlet.h> |
2ae00b68 |
16 | |
17 | static bool |
18 | constant(name, pval) |
19 | char *name; |
20 | IV *pval; |
21 | { |
22 | if (strnNE(name, "O_", 2)) return FALSE; |
23 | |
24 | if (strEQ(name, "O_APPEND")) |
25 | #ifdef O_APPEND |
26 | { *pval = O_APPEND; return TRUE; } |
27 | #else |
28 | return FALSE; |
29 | #endif |
30 | if (strEQ(name, "O_CREAT")) |
31 | #ifdef O_CREAT |
32 | { *pval = O_CREAT; return TRUE; } |
33 | #else |
34 | return FALSE; |
35 | #endif |
36 | if (strEQ(name, "O_EXCL")) |
37 | #ifdef O_EXCL |
38 | { *pval = O_EXCL; return TRUE; } |
39 | #else |
40 | return FALSE; |
41 | #endif |
42 | if (strEQ(name, "O_NDELAY")) |
43 | #ifdef O_NDELAY |
44 | { *pval = O_NDELAY; return TRUE; } |
45 | #else |
46 | return FALSE; |
47 | #endif |
48 | if (strEQ(name, "O_NOWAIT")) |
49 | #ifdef O_NOWAIT |
50 | { *pval = O_NOWAIT; return TRUE; } |
51 | #else |
52 | return FALSE; |
53 | #endif |
54 | if (strEQ(name, "O_RDONLY")) |
55 | #ifdef O_RDONLY |
56 | { *pval = O_RDONLY; return TRUE; } |
57 | #else |
58 | return FALSE; |
59 | #endif |
60 | if (strEQ(name, "O_RDWR")) |
61 | #ifdef O_RDWR |
62 | { *pval = O_RDWR; return TRUE; } |
63 | #else |
64 | return FALSE; |
65 | #endif |
66 | if (strEQ(name, "O_TRUNC")) |
67 | #ifdef O_TRUNC |
68 | { *pval = O_TRUNC; return TRUE; } |
69 | #else |
70 | return FALSE; |
71 | #endif |
72 | if (strEQ(name, "O_WRONLY")) |
73 | #ifdef O_WRONLY |
74 | { *pval = O_WRONLY; return TRUE; } |
75 | #else |
76 | return FALSE; |
77 | #endif |
78 | |
79 | return FALSE; |
80 | } |
748a9306 |
81 | |
748a9306 |
82 | |
2ae00b68 |
83 | static SV * |
a15cef0c |
84 | newFH(PerlIO *fp, char type) { |
55497cff |
85 | SV *rv; |
86 | GV **stashp, *gv = (GV *)NEWSV(0,0); |
2ae00b68 |
87 | HV *stash; |
88 | IO *io; |
89 | |
90 | /* Find stash for VMS::Stdio. We don't do this once at boot |
91 | * to allow for possibility of threaded Perl with per-thread |
92 | * symbol tables. This code (through io = ...) is really |
93 | * equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO), |
94 | * with a little less overhead, and good exercise for me. :-) */ |
6b88bc9c |
95 | stashp = (GV **)hv_fetch(PL_defstash,"VMS::",5,TRUE); |
96 | if (!stashp || *stashp == (GV *)&PL_sv_undef) return Nullsv; |
2ae00b68 |
97 | if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV(); |
98 | stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE); |
6b88bc9c |
99 | if (!stashp || *stashp == (GV *)&PL_sv_undef) return Nullsv; |
2ae00b68 |
100 | if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV(); |
101 | |
102 | /* Set up GV to point to IO, and then take reference */ |
103 | gv_init(gv,stash,"__FH__",6,0); |
104 | io = GvIOp(gv) = newIO(); |
105 | IoIFP(io) = fp; |
5f05dabc |
106 | if (type != '<') IoOFP(io) = fp; |
2ae00b68 |
107 | IoTYPE(io) = type; |
55497cff |
108 | rv = newRV((SV *)gv); |
2ae00b68 |
109 | SvREFCNT_dec(gv); |
110 | return sv_bless(rv,stash); |
111 | } |
112 | |
113 | MODULE = VMS::Stdio PACKAGE = VMS::Stdio |
748a9306 |
114 | |
115 | void |
2ae00b68 |
116 | constant(name) |
748a9306 |
117 | char * name |
2ae00b68 |
118 | PROTOTYPE: $ |
119 | CODE: |
120 | IV i; |
121 | if (constant(name, &i)) |
122 | ST(0) = sv_2mortal(newSViv(i)); |
123 | else |
6b88bc9c |
124 | ST(0) = &PL_sv_undef; |
2ae00b68 |
125 | |
126 | void |
562a7b0c |
127 | binmode(fh) |
128 | SV * fh |
129 | PROTOTYPE: $ |
130 | CODE: |
131 | IO *io = sv_2io(fh); |
a15cef0c |
132 | PerlIO *fp = io ? IoOFP(io) : NULL; |
562a7b0c |
133 | char iotype = io ? IoTYPE(io) : '\0'; |
134 | char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch; |
135 | int ret = 0, saverrno = errno, savevmserrno = vaxc$errno; |
a15cef0c |
136 | SV pos; |
562a7b0c |
137 | if (fp == NULL || strchr(">was+-|",iotype) == Nullch) { |
138 | set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF; |
139 | } |
a15cef0c |
140 | if (!PerlIO_getname(fp,filespec)) XSRETURN_UNDEF; |
562a7b0c |
141 | for (s = filespec; *s; s++) { |
142 | if (*s == ':') colon = s; |
143 | else if (*s == ']' || *s == '>') dirend = s; |
144 | } |
145 | /* Looks like a tmpfile, which will go away if reopened */ |
146 | if (s == dirend + 3) { |
147 | set_errno(EBADF); set_vaxc_errno(RMS$_IOP); XSRETURN_UNDEF; |
148 | } |
149 | /* If we've got a non-file-structured device, clip off the trailing |
150 | * junk, and don't lose sleep if we can't get a stream position. */ |
151 | if (dirend == Nullch) *(colon+1) = '\0'; |
a15cef0c |
152 | if (iotype != '-' && (ret = PerlIO_getpos(fp, &pos)) == -1 && dirend) |
562a7b0c |
153 | XSRETURN_UNDEF; |
154 | switch (iotype) { |
155 | case '<': case 'r': acmode = "rb"; break; |
156 | case '>': case 'w': case '|': |
157 | /* use 'a' instead of 'w' to avoid creating new file; |
158 | fsetpos below will take care of restoring file position */ |
159 | case 'a': acmode = "ab"; break; |
160 | case '+': case 's': acmode = "rb+"; break; |
a15cef0c |
161 | case '-': acmode = PerlIO_fileno(fp) ? "ab" : "rb"; break; |
562a7b0c |
162 | /* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */ |
163 | /* since we didn't really open them and can't really */ |
164 | /* reopen them */ |
165 | case 0: XSRETURN_UNDEF; |
166 | default: |
167 | if (PL_dowarn) warn("Unrecognized iotype %c for %s in binmode", |
168 | iotype, filespec); |
169 | acmode = "rb+"; |
170 | } |
a15cef0c |
171 | /* appearances to the contrary, this is an freopen substitute */ |
172 | SV *name = sv_2mortal(newSVpvn(filespec,strlen(filespec))); |
173 | if (PerlIO_openn(Nullch,acmode,-1,0,0,fp,1,&name) == Nullfp) XSRETURN_UNDEF; |
174 | if (iotype != '-' && ret != -1 && PerlIO_setpos(fp,&pos) == -1) XSRETURN_UNDEF; |
562a7b0c |
175 | if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); } |
176 | XSRETURN_YES; |
177 | |
178 | |
179 | void |
17f28c40 |
180 | flush(fp) |
a15cef0c |
181 | PerlIO * fp |
2ae00b68 |
182 | PROTOTYPE: $ |
183 | CODE: |
a15cef0c |
184 | FILE *stdio = PerlIO_exportFILE(fp,0); |
185 | if (fflush(stdio)) { ST(0) = &PL_sv_undef; } |
186 | else { clearerr(stdio); ST(0) = &PL_sv_yes; } |
187 | PerlIO_releaseFILE(fp,stdio); |
2ae00b68 |
188 | |
189 | char * |
190 | getname(fp) |
a15cef0c |
191 | PerlIO * fp |
2ae00b68 |
192 | PROTOTYPE: $ |
193 | CODE: |
17f28c40 |
194 | char fname[NAM$C_MAXRSS+1]; |
2ae00b68 |
195 | ST(0) = sv_newmortal(); |
a15cef0c |
196 | if (PerlIO_getname(fp,fname) != NULL) sv_setpv(ST(0),fname); |
2ae00b68 |
197 | |
198 | void |
199 | rewind(fp) |
a15cef0c |
200 | PerlIO * fp |
2ae00b68 |
201 | PROTOTYPE: $ |
202 | CODE: |
a15cef0c |
203 | FILE *stdio = PerlIO_exportFILE(fp,0); |
204 | ST(0) = rewind(stdio) ? &PL_sv_undef : &PL_sv_yes; |
205 | PerlIO_releaseFILE(fp,stdio); |
2ae00b68 |
206 | |
207 | void |
208 | remove(name) |
209 | char *name |
210 | PROTOTYPE: $ |
211 | CODE: |
6b88bc9c |
212 | ST(0) = remove(name) ? &PL_sv_undef : &PL_sv_yes; |
2ae00b68 |
213 | |
214 | void |
17f28c40 |
215 | setdef(...) |
216 | PROTOTYPE: @ |
217 | CODE: |
218 | char vmsdef[NAM$C_MAXRSS+1], es[NAM$C_MAXRSS], sep; |
219 | unsigned long int retsts; |
220 | struct FAB deffab = cc$rms_fab; |
221 | struct NAM defnam = cc$rms_nam; |
222 | struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; |
2d8e6c8d |
223 | STRLEN n_a; |
17f28c40 |
224 | if (items) { |
225 | SV *defsv = ST(items-1); /* mimic chdir() */ |
6b88bc9c |
226 | ST(0) = &PL_sv_undef; |
17f28c40 |
227 | if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); } |
2d8e6c8d |
228 | if (tovmsspec(SvPV(defsv,n_a),vmsdef) == NULL) { XSRETURN(1); } |
17f28c40 |
229 | deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef); |
230 | } |
231 | else { |
232 | deffab.fab$l_fna = "SYS$LOGIN"; deffab.fab$b_fns = 9; |
6b88bc9c |
233 | EXTEND(sp,1); ST(0) = &PL_sv_undef; |
17f28c40 |
234 | } |
235 | defnam.nam$l_esa = es; defnam.nam$b_ess = sizeof es; |
236 | deffab.fab$l_nam = &defnam; |
237 | retsts = sys$parse(&deffab,0,0); |
238 | if (retsts & 1) { |
239 | if (defnam.nam$v_wildcard) retsts = RMS$_WLD; |
240 | else if (defnam.nam$b_name || defnam.nam$b_type > 1 || |
241 | defnam.nam$b_ver > 1) retsts = RMS$_DIR; |
242 | } |
243 | defnam.nam$b_nop |= NAM$M_SYNCHK; defnam.nam$l_rlf = NULL; deffab.fab$b_dns = 0; |
244 | if (!(retsts & 1)) { |
245 | set_vaxc_errno(retsts); |
246 | switch (retsts) { |
247 | case RMS$_DNF: |
248 | set_errno(ENOENT); break; |
249 | case RMS$_SYN: case RMS$_DIR: case RMS$_DEV: |
250 | set_errno(EINVAL); break; |
251 | case RMS$_PRV: |
252 | set_errno(EACCES); break; |
253 | default: |
254 | set_errno(EVMSERR); break; |
255 | } |
256 | (void) sys$parse(&deffab,0,0); /* free up context */ |
257 | XSRETURN(1); |
258 | } |
259 | sep = *defnam.nam$l_dir; |
260 | *defnam.nam$l_dir = '\0'; |
261 | my_setenv("SYS$DISK",defnam.nam$b_node ? defnam.nam$l_node : defnam.nam$l_dev); |
262 | *defnam.nam$l_dir = sep; |
263 | dirdsc.dsc$a_pointer = defnam.nam$l_dir; dirdsc.dsc$w_length = defnam.nam$b_dir; |
6b88bc9c |
264 | if ((retsts = sys$setddir(&dirdsc,0,0)) & 1) ST(0) = &PL_sv_yes; |
17f28c40 |
265 | else { set_errno(EVMSERR); set_vaxc_errno(retsts); } |
266 | (void) sys$parse(&deffab,0,0); /* free up context */ |
267 | |
268 | void |
2ae00b68 |
269 | sync(fp) |
a15cef0c |
270 | PerlIO * fp |
2ae00b68 |
271 | PROTOTYPE: $ |
272 | CODE: |
a15cef0c |
273 | FILE *stdio = PerlIO_exportFILE(fp,0); |
274 | if (fsync(fileno(stdio))) { ST(0) = &PL_sv_undef; } |
275 | else { clearerr(stdio); ST(0) = &PL_sv_yes; } |
276 | PerlIO_releaseFILE(fp,stdio); |
2ae00b68 |
277 | |
278 | char * |
279 | tmpnam() |
280 | PROTOTYPE: |
281 | CODE: |
282 | char fname[L_tmpnam]; |
283 | ST(0) = sv_newmortal(); |
284 | if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname); |
285 | |
286 | void |
287 | vmsopen(spec,...) |
288 | char * spec |
289 | PROTOTYPE: @ |
748a9306 |
290 | CODE: |
2ae00b68 |
291 | char *args[8],mode[3] = {'r','\0','\0'}, type = '<'; |
748a9306 |
292 | register int i, myargc; |
293 | FILE *fp; |
a15cef0c |
294 | PerlIO *pio_fp; |
2d8e6c8d |
295 | STRLEN n_a; |
2ae00b68 |
296 | |
297 | if (!spec || !*spec) { |
298 | SETERRNO(EINVAL,LIB$_INVARG); |
299 | XSRETURN_UNDEF; |
748a9306 |
300 | } |
2ae00b68 |
301 | if (items > 9) croak("too many args"); |
302 | |
748a9306 |
303 | /* First, set up name and mode args from perl's string */ |
2ae00b68 |
304 | if (*spec == '+') { |
748a9306 |
305 | mode[1] = '+'; |
2ae00b68 |
306 | spec++; |
748a9306 |
307 | } |
2ae00b68 |
308 | if (*spec == '>') { |
309 | if (*(spec+1) == '>') *mode = 'a', spec += 2; |
310 | else *mode = 'w', spec++; |
748a9306 |
311 | } |
2ae00b68 |
312 | else if (*spec == '<') spec++; |
748a9306 |
313 | myargc = items - 1; |
2d8e6c8d |
314 | for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),n_a); |
748a9306 |
315 | /* This hack brought to you by C's opaque arglist management */ |
316 | switch (myargc) { |
317 | case 0: |
2ae00b68 |
318 | fp = fopen(spec,mode); |
748a9306 |
319 | break; |
320 | case 1: |
2ae00b68 |
321 | fp = fopen(spec,mode,args[0]); |
748a9306 |
322 | break; |
323 | case 2: |
2ae00b68 |
324 | fp = fopen(spec,mode,args[0],args[1]); |
748a9306 |
325 | break; |
326 | case 3: |
2ae00b68 |
327 | fp = fopen(spec,mode,args[0],args[1],args[2]); |
748a9306 |
328 | break; |
329 | case 4: |
2ae00b68 |
330 | fp = fopen(spec,mode,args[0],args[1],args[2],args[3]); |
748a9306 |
331 | break; |
332 | case 5: |
2ae00b68 |
333 | fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]); |
748a9306 |
334 | break; |
335 | case 6: |
2ae00b68 |
336 | fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]); |
748a9306 |
337 | break; |
338 | case 7: |
2ae00b68 |
339 | fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]); |
748a9306 |
340 | break; |
341 | case 8: |
2ae00b68 |
342 | fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]); |
748a9306 |
343 | break; |
344 | } |
a15cef0c |
345 | if (fp != Null(FILE*)) { |
346 | pio_fp = PerlIO_importFILE(fp,0); |
347 | SV *fh = newFH(pio_fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>')))); |
6b88bc9c |
348 | ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef); |
748a9306 |
349 | } |
6b88bc9c |
350 | else { ST(0) = &PL_sv_undef; } |
748a9306 |
351 | |
2ae00b68 |
352 | void |
353 | vmssysopen(spec,mode,perm,...) |
354 | char * spec |
355 | int mode |
356 | int perm |
357 | PROTOTYPE: @ |
748a9306 |
358 | CODE: |
2ae00b68 |
359 | char *args[8]; |
360 | int i, myargc, fd; |
361 | FILE *fp; |
a15cef0c |
362 | PerlIO *pio_fp; |
2ae00b68 |
363 | SV *fh; |
2d8e6c8d |
364 | STRLEN n_a; |
2ae00b68 |
365 | if (!spec || !*spec) { |
366 | SETERRNO(EINVAL,LIB$_INVARG); |
367 | XSRETURN_UNDEF; |
368 | } |
369 | if (items > 11) croak("too many args"); |
370 | myargc = items - 3; |
2d8e6c8d |
371 | for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),n_a); |
2ae00b68 |
372 | /* More fun with C calls; can't combine with above because |
373 | args 2,3 of different types in fopen() and open() */ |
374 | switch (myargc) { |
375 | case 0: |
376 | fd = open(spec,mode,perm); |
377 | break; |
378 | case 1: |
379 | fd = open(spec,mode,perm,args[0]); |
380 | break; |
381 | case 2: |
382 | fd = open(spec,mode,perm,args[0],args[1]); |
383 | break; |
384 | case 3: |
385 | fd = open(spec,mode,perm,args[0],args[1],args[2]); |
386 | break; |
387 | case 4: |
388 | fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]); |
389 | break; |
390 | case 5: |
391 | fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]); |
392 | break; |
393 | case 6: |
394 | fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]); |
395 | break; |
396 | case 7: |
397 | fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]); |
398 | break; |
399 | case 8: |
400 | fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]); |
401 | break; |
402 | } |
403 | i = mode & 3; |
404 | if (fd >= 0 && |
a15cef0c |
405 | ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Null(FILE*))) { |
406 | pio_fp = PerlIO_importFILE(fp,0); |
407 | SV *fh = newFH(pio_fp,"<>++"[i]); |
6b88bc9c |
408 | ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef); |
2ae00b68 |
409 | } |
6b88bc9c |
410 | else { ST(0) = &PL_sv_undef; } |
748a9306 |
411 | |
2ae00b68 |
412 | void |
413 | waitfh(fp) |
a15cef0c |
414 | PerlIO * fp |
2ae00b68 |
415 | PROTOTYPE: $ |
748a9306 |
416 | CODE: |
a15cef0c |
417 | FILE *stdio = PerlIO_exportFILE(fp,0); |
418 | ST(0) = fwait(stdio) ? &PL_sv_undef : &PL_sv_yes; |
419 | PerlIO_releaseFILE(fp,stdio); |
17f28c40 |
420 | |
421 | void |
422 | writeof(mysv) |
423 | SV * mysv |
424 | PROTOTYPE: $ |
425 | CODE: |
426 | char devnam[257], *cp; |
427 | unsigned long int chan, iosb[2], retsts, retsts2; |
428 | struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam}; |
429 | IO *io = sv_2io(mysv); |
a15cef0c |
430 | PerlIO *fp = io ? IoOFP(io) : NULL; |
17f28c40 |
431 | if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) { |
562a7b0c |
432 | set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF; |
17f28c40 |
433 | } |
a15cef0c |
434 | if (PerlIO_getname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef; XSRETURN(1); } |
17f28c40 |
435 | if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0'; |
436 | devdsc.dsc$w_length = strlen(devnam); |
437 | retsts = sys$assign(&devdsc,&chan,0,0); |
438 | if (retsts & 1) retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0); |
439 | if (retsts & 1) retsts = iosb[0]; |
440 | retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */ |
441 | if (retsts & 1) retsts = retsts2; |
6b88bc9c |
442 | if (retsts & 1) { ST(0) = &PL_sv_yes; } |
17f28c40 |
443 | else { |
444 | set_vaxc_errno(retsts); |
445 | switch (retsts) { |
446 | case SS$_EXQUOTA: case SS$_INSFMEM: case SS$_MBFULL: |
447 | case SS$_MBTOOSML: case SS$_NOIOCHAN: case SS$_NOLINKS: |
448 | case SS$_BUFFEROVF: |
449 | set_errno(ENOSPC); break; |
450 | case SS$_ILLIOFUNC: case SS$_DEVOFFLINE: case SS$_NOSUCHDEV: |
451 | set_errno(EBADF); break; |
452 | case SS$_NOPRIV: |
453 | set_errno(EACCES); break; |
454 | default: /* Includes "shouldn't happen" cases that might map */ |
455 | set_errno(EVMSERR); break; /* to other errno values */ |
456 | } |
6b88bc9c |
457 | ST(0) = &PL_sv_undef; |
17f28c40 |
458 | } |