1 /* VMS::Stdio - VMS extensions to stdio routines
2 *
3 * Version: 2.2
4 * Author: Charles Bailey bailey@newman.upenn.edu
5 * Revised: 18-Jul-1998
6 *
7 */
8
9 #include "EXTERN.h"
10 #include "perl.h"
11 #include "XSUB.h"
12 #include <file.h>
13 #include <iodef.h>
14 #include <rms.h>
15 #include <starlet.h>
16
17 static bool
constant(name,pval)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 }
81
82
83 static SV *
newFH(PerlIO * fp,char type)84 newFH(PerlIO *fp, char type) {
85 SV *rv;
86 GV **stashp, *gv = (GV *)NEWSV(0,0);
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. :-) */
95 stashp = (GV **)hv_fetch(PL_defstash,"VMS::",5,TRUE);
96 if (!stashp || *stashp == (GV *)&PL_sv_undef) return Nullsv;
97 if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
98 stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE);
99 if (!stashp || *stashp == (GV *)&PL_sv_undef) return Nullsv;
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;
106 if (type != '<') IoOFP(io) = fp;
107 IoTYPE(io) = type;
108 rv = newRV((SV *)gv);
109 SvREFCNT_dec(gv);
110 return sv_bless(rv,stash);
111 }
112
113 MODULE = VMS::Stdio PACKAGE = VMS::Stdio
114
115 void
116 constant(name)
117 char * name
118 PROTOTYPE: $
119 CODE:
120 IV i;
121 if (constant(name, &i))
122 ST(0) = sv_2mortal(newSViv(i));
123 else
124 ST(0) = &PL_sv_undef;
125
126 void
127 binmode(fh)
128 SV * fh
129 PROTOTYPE: $
130 CODE:
131 SV *name;
132 IO *io;
133 char iotype;
134 char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
135 int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
136 SV pos;
137 PerlIO *fp;
138 io = sv_2io(fh);
139 fp = io ? IoOFP(io) : NULL;
140 iotype = io ? IoTYPE(io) : '\0';
141 if (fp == NULL || strchr(">was+-|",iotype) == Nullch) {
142 set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
143 }
144 if (!PerlIO_getname(fp,filespec)) XSRETURN_UNDEF;
145 for (s = filespec; *s; s++) {
146 if (*s == ':') colon = s;
147 else if (*s == ']' || *s == '>') dirend = s;
148 }
149 /* Looks like a tmpfile, which will go away if reopened */
150 if (s == dirend + 3) {
151 set_errno(EBADF); set_vaxc_errno(RMS$_IOP); XSRETURN_UNDEF;
152 }
153 /* If we've got a non-file-structured device, clip off the trailing
154 * junk, and don't lose sleep if we can't get a stream position. */
155 if (dirend == Nullch) *(colon+1) = '\0';
156 if (iotype != '-' && (ret = PerlIO_getpos(fp, &pos)) == -1 && dirend)
157 XSRETURN_UNDEF;
158 switch (iotype) {
159 case '<': case 'r': acmode = "rb"; break;
160 case '>': case 'w': case '|':
161 /* use 'a' instead of 'w' to avoid creating new file;
162 fsetpos below will take care of restoring file position */
163 case 'a': acmode = "ab"; break;
164 case '+': case 's': acmode = "rb+"; break;
165 case '-': acmode = PerlIO_fileno(fp) ? "ab" : "rb"; break;
166 /* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
167 /* since we didn't really open them and can't really */
168 /* reopen them */
169 case 0: XSRETURN_UNDEF;
170 default:
171 if (PL_dowarn) warn("Unrecognized iotype %c for %s in binmode",
172 iotype, filespec);
173 acmode = "rb+";
174 }
175 /* appearances to the contrary, this is an freopen substitute */
176 name = sv_2mortal(newSVpvn(filespec,strlen(filespec)));
177 if (PerlIO_openn(aTHX_ Nullch,acmode,-1,0,0,fp,1,&name) == Nullfp) XSRETURN_UNDEF;
178 if (iotype != '-' && ret != -1 && PerlIO_setpos(fp,&pos) == -1) XSRETURN_UNDEF;
179 if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
180 XSRETURN_YES;
181
182
183 void
184 flush(fp)
185 PerlIO * fp
186 PROTOTYPE: $
187 CODE:
188 FILE *stdio = PerlIO_exportFILE(fp,0);
189 if (fflush(stdio)) { ST(0) = &PL_sv_undef; }
190 else { clearerr(stdio); ST(0) = &PL_sv_yes; }
191 PerlIO_releaseFILE(fp,stdio);
192
193 char *
194 getname(fp)
195 PerlIO * fp
196 PROTOTYPE: $
197 CODE:
198 char fname[NAM$C_MAXRSS+1];
199 ST(0) = sv_newmortal();
200 if (PerlIO_getname(fp,fname) != NULL) sv_setpv(ST(0),fname);
201
202 void
203 rewind(fp)
204 PerlIO * fp
205 PROTOTYPE: $
206 CODE:
207 FILE *stdio = PerlIO_exportFILE(fp,0);
208 ST(0) = rewind(stdio) ? &PL_sv_undef : &PL_sv_yes;
209 PerlIO_releaseFILE(fp,stdio);
210
211 void
212 remove(name)
213 char *name
214 PROTOTYPE: $
215 CODE:
216 ST(0) = remove(name) ? &PL_sv_undef : &PL_sv_yes;
217
218 void
219 setdef(...)
220 PROTOTYPE: @
221 CODE:
222 char vmsdef[NAM$C_MAXRSS+1], es[NAM$C_MAXRSS], sep;
223 unsigned long int retsts;
224 struct FAB deffab = cc$rms_fab;
225 struct NAM defnam = cc$rms_nam;
226 struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
227 STRLEN n_a;
228 if (items) {
229 SV *defsv = ST(items-1); /* mimic chdir() */
230 ST(0) = &PL_sv_undef;
231 if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); }
232 if (tovmsspec(SvPV(defsv,n_a),vmsdef) == NULL) { XSRETURN(1); }
233 deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef);
234 }
235 else {
236 deffab.fab$l_fna = "SYS$LOGIN"; deffab.fab$b_fns = 9;
237 EXTEND(sp,1); ST(0) = &PL_sv_undef;
238 }
239 defnam.nam$l_esa = es; defnam.nam$b_ess = sizeof es;
240 deffab.fab$l_nam = &defnam;
241 retsts = sys$parse(&deffab,0,0);
242 if (retsts & 1) {
243 if (defnam.nam$v_wildcard) retsts = RMS$_WLD;
244 else if (defnam.nam$b_name || defnam.nam$b_type > 1 ||
245 defnam.nam$b_ver > 1) retsts = RMS$_DIR;
246 }
247 defnam.nam$b_nop |= NAM$M_SYNCHK; defnam.nam$l_rlf = NULL; deffab.fab$b_dns = 0;
248 if (!(retsts & 1)) {
249 set_vaxc_errno(retsts);
250 switch (retsts) {
251 case RMS$_DNF:
252 set_errno(ENOENT); break;
253 case RMS$_SYN: case RMS$_DIR: case RMS$_DEV:
254 set_errno(EINVAL); break;
255 case RMS$_PRV:
256 set_errno(EACCES); break;
257 default:
258 set_errno(EVMSERR); break;
259 }
260 (void) sys$parse(&deffab,0,0); /* free up context */
261 XSRETURN(1);
262 }
263 sep = *defnam.nam$l_dir;
264 *defnam.nam$l_dir = '\0';
265 my_setenv("SYS$DISK",defnam.nam$b_node ? defnam.nam$l_node : defnam.nam$l_dev);
266 *defnam.nam$l_dir = sep;
267 dirdsc.dsc$a_pointer = defnam.nam$l_dir; dirdsc.dsc$w_length = defnam.nam$b_dir;
268 if ((retsts = sys$setddir(&dirdsc,0,0)) & 1) ST(0) = &PL_sv_yes;
269 else { set_errno(EVMSERR); set_vaxc_errno(retsts); }
270 (void) sys$parse(&deffab,0,0); /* free up context */
271
272 void
273 sync(fp)
274 PerlIO * fp
275 PROTOTYPE: $
276 CODE:
277 FILE *stdio = PerlIO_exportFILE(fp,0);
278 if (fsync(fileno(stdio))) { ST(0) = &PL_sv_undef; }
279 else { clearerr(stdio); ST(0) = &PL_sv_yes; }
280 PerlIO_releaseFILE(fp,stdio);
281
282 char *
283 tmpnam()
284 PROTOTYPE:
285 CODE:
286 char fname[L_tmpnam];
287 ST(0) = sv_newmortal();
288 if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
289
290 void
291 vmsopen(spec,...)
292 char * spec
293 PROTOTYPE: @
294 CODE:
295 char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
296 register int i, myargc;
297 FILE *fp;
298 SV *fh;
299 PerlIO *pio_fp;
300 STRLEN n_a;
301
302 if (!spec || !*spec) {
303 SETERRNO(EINVAL,LIB$_INVARG);
304 XSRETURN_UNDEF;
305 }
306 if (items > 9) croak("too many args");
307
308 /* First, set up name and mode args from perl's string */
309 if (*spec == '+') {
310 mode[1] = '+';
311 spec++;
312 }
313 if (*spec == '>') {
314 if (*(spec+1) == '>') *mode = 'a', spec += 2;
315 else *mode = 'w', spec++;
316 }
317 else if (*spec == '<') spec++;
318 myargc = items - 1;
319 for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),n_a);
320 /* This hack brought to you by C's opaque arglist management */
321 switch (myargc) {
322 case 0:
323 fp = fopen(spec,mode);
324 break;
325 case 1:
326 fp = fopen(spec,mode,args[0]);
327 break;
328 case 2:
329 fp = fopen(spec,mode,args[0],args[1]);
330 break;
331 case 3:
332 fp = fopen(spec,mode,args[0],args[1],args[2]);
333 break;
334 case 4:
335 fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
336 break;
337 case 5:
338 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
339 break;
340 case 6:
341 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
342 break;
343 case 7:
344 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
345 break;
346 case 8:
347 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
348 break;
349 }
350 if (fp != Null(FILE*)) {
351 pio_fp = PerlIO_importFILE(fp,mode);
352 fh = newFH(pio_fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
353 ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
354 }
355 else { ST(0) = &PL_sv_undef; }
356
357 void
358 vmssysopen(spec,mode,perm,...)
359 char * spec
360 int mode
361 int perm
362 PROTOTYPE: @
363 CODE:
364 char *args[8];
365 int i, myargc, fd;
366 FILE *fp;
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 ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Null(FILE*))) {
411 pio_fp = PerlIO_importFILE(fp,&("r\000w\000r+"[2*i]));
412 fh = newFH(pio_fp,"<>++"[i]);
413 ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
414 }
415 else { ST(0) = &PL_sv_undef; }
416
417 void
418 waitfh(fp)
419 PerlIO * fp
420 PROTOTYPE: $
421 CODE:
422 FILE *stdio = PerlIO_exportFILE(fp,0);
423 ST(0) = fwait(stdio) ? &PL_sv_undef : &PL_sv_yes;
424 PerlIO_releaseFILE(fp,stdio);
425
426 void
427 writeof(mysv)
428 SV * mysv
429 PROTOTYPE: $
430 CODE:
431 char devnam[257], *cp;
432 unsigned long int chan, iosb[2], retsts, retsts2;
433 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
434 IO *io = sv_2io(mysv);
IoOFP(io)435 PerlIO *fp = io ? IoOFP(io) : NULL;
436 if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) {
437 set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
438 }
439 if (PerlIO_getname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef; XSRETURN(1); }
440 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
441 devdsc.dsc$w_length = strlen(devnam);
442 retsts = sys$assign(&devdsc,&chan,0,0);
443 if (retsts & 1) retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
444 if (retsts & 1) retsts = iosb[0];
445 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
446 if (retsts & 1) retsts = retsts2;
447 if (retsts & 1) { ST(0) = &PL_sv_yes; }
448 else {
449 set_vaxc_errno(retsts);
450 switch (retsts) {
451 case SS$_EXQUOTA: case SS$_INSFMEM: case SS$_MBFULL:
452 case SS$_MBTOOSML: case SS$_NOIOCHAN: case SS$_NOLINKS:
453 case SS$_BUFFEROVF:
454 set_errno(ENOSPC); break;
455 case SS$_ILLIOFUNC: case SS$_DEVOFFLINE: case SS$_NOSUCHDEV:
456 set_errno(EBADF); break;
457 case SS$_NOPRIV:
458 set_errno(EACCES); break;
459 default: /* Includes "shouldn't happen" cases that might map */
460 set_errno(EVMSERR); break; /* to other errno values */
461 }
462 ST(0) = &PL_sv_undef;
463 }
464