1 /* VMS::Stdio - VMS extensions to stdio routines
4 * Author: Charles Bailey bailey@genetics.upenn.edu
22 if (strnNE(name, "O_", 2)) return FALSE;
24 if (strEQ(name, "O_APPEND"))
26 { *pval = O_APPEND; return TRUE; }
30 if (strEQ(name, "O_CREAT"))
32 { *pval = O_CREAT; return TRUE; }
36 if (strEQ(name, "O_EXCL"))
38 { *pval = O_EXCL; return TRUE; }
42 if (strEQ(name, "O_NDELAY"))
44 { *pval = O_NDELAY; return TRUE; }
48 if (strEQ(name, "O_NOWAIT"))
50 { *pval = O_NOWAIT; return TRUE; }
54 if (strEQ(name, "O_RDONLY"))
56 { *pval = O_RDONLY; return TRUE; }
60 if (strEQ(name, "O_RDWR"))
62 { *pval = O_RDWR; return TRUE; }
66 if (strEQ(name, "O_TRUNC"))
68 { *pval = O_TRUNC; return TRUE; }
72 if (strEQ(name, "O_WRONLY"))
74 { *pval = O_WRONLY; return TRUE; }
84 newFH(FILE *fp, char type) {
86 GV **stashp, *gv = (GV *)NEWSV(0,0);
91 /* Find stash for VMS::Stdio. We don't do this once at boot
92 * to allow for possibility of threaded Perl with per-thread
93 * symbol tables. This code (through io = ...) is really
94 * equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO),
95 * with a little less overhead, and good exercise for me. :-) */
96 stashp = (GV **)hv_fetch(defstash,"VMS::",5,TRUE);
97 if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv;
98 if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
99 stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE);
100 if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv;
101 if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
103 /* Set up GV to point to IO, and then take reference */
104 gv_init(gv,stash,"__FH__",6,0);
105 io = GvIOp(gv) = newIO();
107 if (type != '<') IoOFP(io) = fp;
109 rv = newRV((SV *)gv);
111 return sv_bless(rv,stash);
114 MODULE = VMS::Stdio PACKAGE = VMS::Stdio
122 if (constant(name, &i))
123 ST(0) = sv_2mortal(newSViv(i));
132 if (fflush(fp)) { ST(0) = &sv_undef; }
133 else { clearerr(fp); ST(0) = &sv_yes; }
140 char fname[NAM$C_MAXRSS+1];
141 ST(0) = sv_newmortal();
142 if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
149 ST(0) = rewind(fp) ? &sv_undef : &sv_yes;
156 ST(0) = remove(name) ? &sv_undef : &sv_yes;
162 char vmsdef[NAM$C_MAXRSS+1], es[NAM$C_MAXRSS], sep;
163 unsigned long int retsts;
164 struct FAB deffab = cc$rms_fab;
165 struct NAM defnam = cc$rms_nam;
166 struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
168 SV *defsv = ST(items-1); /* mimic chdir() */
170 if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); }
171 if (tovmsspec(SvPV(defsv,na),vmsdef) == NULL) { XSRETURN(1); }
172 deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef);
175 deffab.fab$l_fna = "SYS$LOGIN"; deffab.fab$b_fns = 9;
176 EXTEND(sp,1); ST(0) = &sv_undef;
178 defnam.nam$l_esa = es; defnam.nam$b_ess = sizeof es;
179 deffab.fab$l_nam = &defnam;
180 retsts = sys$parse(&deffab,0,0);
182 if (defnam.nam$v_wildcard) retsts = RMS$_WLD;
183 else if (defnam.nam$b_name || defnam.nam$b_type > 1 ||
184 defnam.nam$b_ver > 1) retsts = RMS$_DIR;
186 defnam.nam$b_nop |= NAM$M_SYNCHK; defnam.nam$l_rlf = NULL; deffab.fab$b_dns = 0;
188 set_vaxc_errno(retsts);
191 set_errno(ENOENT); break;
192 case RMS$_SYN: case RMS$_DIR: case RMS$_DEV:
193 set_errno(EINVAL); break;
195 set_errno(EACCES); break;
197 set_errno(EVMSERR); break;
199 (void) sys$parse(&deffab,0,0); /* free up context */
202 sep = *defnam.nam$l_dir;
203 *defnam.nam$l_dir = '\0';
204 my_setenv("SYS$DISK",defnam.nam$b_node ? defnam.nam$l_node : defnam.nam$l_dev);
205 *defnam.nam$l_dir = sep;
206 dirdsc.dsc$a_pointer = defnam.nam$l_dir; dirdsc.dsc$w_length = defnam.nam$b_dir;
207 if ((retsts = sys$setddir(&dirdsc,0,0)) & 1) ST(0) = &sv_yes;
208 else { set_errno(EVMSERR); set_vaxc_errno(retsts); }
209 (void) sys$parse(&deffab,0,0); /* free up context */
216 if (fsync(fileno(fp))) { ST(0) = &sv_undef; }
217 else { clearerr(fp); ST(0) = &sv_yes; }
223 char fname[L_tmpnam];
224 ST(0) = sv_newmortal();
225 if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
232 char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
233 register int i, myargc;
236 if (!spec || !*spec) {
237 SETERRNO(EINVAL,LIB$_INVARG);
240 if (items > 9) croak("too many args");
242 /* First, set up name and mode args from perl's string */
248 if (*(spec+1) == '>') *mode = 'a', spec += 2;
249 else *mode = 'w', spec++;
251 else if (*spec == '<') spec++;
253 for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),na);
254 /* This hack brought to you by C's opaque arglist management */
257 fp = fopen(spec,mode);
260 fp = fopen(spec,mode,args[0]);
263 fp = fopen(spec,mode,args[0],args[1]);
266 fp = fopen(spec,mode,args[0],args[1],args[2]);
269 fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
272 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
275 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
278 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
281 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
285 SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
286 ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
288 else { ST(0) = &sv_undef; }
291 vmssysopen(spec,mode,perm,...)
301 if (!spec || !*spec) {
302 SETERRNO(EINVAL,LIB$_INVARG);
305 if (items > 11) croak("too many args");
307 for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),na);
308 /* More fun with C calls; can't combine with above because
309 args 2,3 of different types in fopen() and open() */
312 fd = open(spec,mode,perm);
315 fd = open(spec,mode,perm,args[0]);
318 fd = open(spec,mode,perm,args[0],args[1]);
321 fd = open(spec,mode,perm,args[0],args[1],args[2]);
324 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]);
327 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]);
330 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]);
333 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
336 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
341 ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) {
342 SV *fh = newFH(fp,"<>++"[i]);
343 ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
345 else { ST(0) = &sv_undef; }
352 ST(0) = fwait(fp) ? &sv_undef : &sv_yes;
359 char devnam[257], *cp;
360 unsigned long int chan, iosb[2], retsts, retsts2;
361 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
362 IO *io = sv_2io(mysv);
363 FILE *fp = io ? IoOFP(io) : NULL;
364 if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) {
365 set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN);
366 ST(0) = &sv_undef; XSRETURN(1);
368 if (fgetname(fp,devnam) == Nullch) { ST(0) = &sv_undef; XSRETURN(1); }
369 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
370 devdsc.dsc$w_length = strlen(devnam);
371 retsts = sys$assign(&devdsc,&chan,0,0);
372 if (retsts & 1) retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
373 if (retsts & 1) retsts = iosb[0];
374 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
375 if (retsts & 1) retsts = retsts2;
376 if (retsts & 1) { ST(0) = &sv_yes; }
378 set_vaxc_errno(retsts);
380 case SS$_EXQUOTA: case SS$_INSFMEM: case SS$_MBFULL:
381 case SS$_MBTOOSML: case SS$_NOIOCHAN: case SS$_NOLINKS:
383 set_errno(ENOSPC); break;
384 case SS$_ILLIOFUNC: case SS$_DEVOFFLINE: case SS$_NOSUCHDEV:
385 set_errno(EBADF); break;
387 set_errno(EACCES); break;
388 default: /* Includes "shouldn't happen" cases that might map */
389 set_errno(EVMSERR); break; /* to other errno values */