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
18static bool
19constant(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
82static SV *
83newFH(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
112MODULE = VMS::Stdio  PACKAGE = VMS::Stdio
113
114void
115constant(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
125void
126binmode(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 || memCHRs(">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
182void
183flush(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
192char *
193getname(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
203void
204rewind(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
212void
213remove(name)
214	char *name
215	PROTOTYPE: $
216	CODE:
217	    ST(0) = remove(name) ? &PL_sv_undef : &PL_sv_yes;
218
219void
220setdef(...)
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
273void
274sync(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
283char *
284tmpnam()
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
291void
292vmsopen(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
358void
359vmssysopen(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
416void
417waitfh(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
425void
426writeof(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);
434           PerlIO *fp = io ? IoOFP(io) : NULL;
435	    if (fp == NULL || memCHRs(">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