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