From: Perl 5 Porters Date: Thu, 29 Feb 1996 02:02:48 +0000 (+0000) Subject: Major rewrite, renaming, and extension X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2ae00b683f65d9797cb0daea56ab5e314b280e49;p=p5sagit%2Fp5-mst-13.2.git Major rewrite, renaming, and extension --- diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs index 737229f..79eb953 100644 --- a/vms/ext/Stdio/Stdio.xs +++ b/vms/ext/Stdio/Stdio.xs @@ -1,110 +1,295 @@ -/* VMS::stdio - VMS extensions to stdio routines +/* VMS::Stdio - VMS extensions to stdio routines * - * Version: 1.1 + * Version: 2.0 * Author: Charles Bailey bailey@genetics.upenn.edu - * Revised: 09-Mar-1995 + * Revised: 28-Feb-1996 * - * - * Revision History: - * - * 1.0 29-Nov-1994 Charles Bailey bailey@genetics.upenn.edu - * original version - vmsfopen - * 1.1 09-Mar-1995 Charles Bailey bailey@genetics.upenn.edu - * changed calling sequence to return FH/undef - like POSIX::open - * added fgetname and tmpnam */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#include + +static bool +constant(name, pval) +char *name; +IV *pval; +{ + if (strnNE(name, "O_", 2)) return FALSE; + + if (strEQ(name, "O_APPEND")) +#ifdef O_APPEND + { *pval = O_APPEND; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "O_CREAT")) +#ifdef O_CREAT + { *pval = O_CREAT; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "O_EXCL")) +#ifdef O_EXCL + { *pval = O_EXCL; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "O_NDELAY")) +#ifdef O_NDELAY + { *pval = O_NDELAY; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "O_NOWAIT")) +#ifdef O_NOWAIT + { *pval = O_NOWAIT; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "O_RDONLY")) +#ifdef O_RDONLY + { *pval = O_RDONLY; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "O_RDWR")) +#ifdef O_RDWR + { *pval = O_RDWR; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "O_TRUNC")) +#ifdef O_TRUNC + { *pval = O_TRUNC; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "O_WRONLY")) +#ifdef O_WRONLY + { *pval = O_WRONLY; return TRUE; } +#else + return FALSE; +#endif + + return FALSE; +} -/* Use type for FILE * from Perl's XSUB typemap. This is a bit - * of a hack, since all Perl filehandles using this type will permit - * both read & write operations, but it saves having to write the PPCODE - * directly for updating the Perl filehandles. - */ -typedef FILE * InOutStream; -MODULE = VMS::stdio PACKAGE = VMS::stdio +static SV * +newFH(FILE *fp, char type) { + SV *rv, *gv = NEWSV(0,0); + GV **stashp; + HV *stash; + IO *io; + + /* Find stash for VMS::Stdio. We don't do this once at boot + * to allow for possibility of threaded Perl with per-thread + * symbol tables. This code (through io = ...) is really + * equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO), + * with a little less overhead, and good exercise for me. :-) */ + stashp = (GV **)hv_fetch(defstash,"VMS::",5,TRUE); + if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv; + if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV(); + stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE); + if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv; + if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV(); + + /* Set up GV to point to IO, and then take reference */ + gv_init(gv,stash,"__FH__",6,0); + io = GvIOp(gv) = newIO(); + IoIFP(io) = fp; + if (type != '>') IoOFP(io) = fp; + IoTYPE(io) = type; + rv = newRV(gv); + SvREFCNT_dec(gv); + return sv_bless(rv,stash); +} + +MODULE = VMS::Stdio PACKAGE = VMS::Stdio void -vmsfopen(name,...) +constant(name) char * name + PROTOTYPE: $ + CODE: + IV i; + if (constant(name, &i)) + ST(0) = sv_2mortal(newSViv(i)); + else + ST(0) = &sv_undef; + +void +flush(sv) + SV * sv + PROTOTYPE: $ + CODE: + FILE *fp = Nullfp; + if (SvOK(sv)) fp = IoIFP(sv_2io(sv)); + ST(0) = fflush(fp) ? &sv_undef : &sv_yes; + +char * +getname(fp) + FILE * fp + PROTOTYPE: $ + CODE: + char fname[257]; + ST(0) = sv_newmortal(); + if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname); + +void +rewind(fp) + FILE * fp + PROTOTYPE: $ + CODE: + ST(0) = rewind(fp) ? &sv_undef : &sv_yes; + +void +remove(name) + char *name + PROTOTYPE: $ + CODE: + ST(0) = remove(name) ? &sv_undef : &sv_yes; + +void +sync(fp) + FILE * fp + PROTOTYPE: $ + CODE: + ST(0) = fsync(fileno(fp)) ? &sv_undef : &sv_yes; + +char * +tmpnam() + PROTOTYPE: + CODE: + char fname[L_tmpnam]; + ST(0) = sv_newmortal(); + if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname); + +void +vmsopen(spec,...) + char * spec + PROTOTYPE: @ CODE: - char *args[8],mode[5] = {'r','\0','\0','\0','\0'}, c; + char *args[8],mode[3] = {'r','\0','\0'}, type = '<'; register int i, myargc; FILE *fp; - if (items > 9) { - croak("File::VMSfopen::vmsfopen - too many args"); + + if (!spec || !*spec) { + SETERRNO(EINVAL,LIB$_INVARG); + XSRETURN_UNDEF; } + if (items > 9) croak("too many args"); + /* First, set up name and mode args from perl's string */ - if (*name == '+') { + if (*spec == '+') { mode[1] = '+'; - name++; + spec++; } - if (*name == '>') { - if (*(name+1) == '>') *mode = 'a', name += 2; - else *mode = 'w', name++; + if (*spec == '>') { + if (*(spec+1) == '>') *mode = 'a', spec += 2; + else *mode = 'w', spec++; } - else if (*name == '<') name++; + else if (*spec == '<') spec++; myargc = items - 1; for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),na); /* This hack brought to you by C's opaque arglist management */ switch (myargc) { case 0: - fp = fopen(name,mode); + fp = fopen(spec,mode); break; case 1: - fp = fopen(name,mode,args[0]); + fp = fopen(spec,mode,args[0]); break; case 2: - fp = fopen(name,mode,args[0],args[1]); + fp = fopen(spec,mode,args[0],args[1]); break; case 3: - fp = fopen(name,mode,args[0],args[1],args[2]); + fp = fopen(spec,mode,args[0],args[1],args[2]); break; case 4: - fp = fopen(name,mode,args[0],args[1],args[2],args[3]); + fp = fopen(spec,mode,args[0],args[1],args[2],args[3]); break; case 5: - fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4]); + fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]); break; case 6: - fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5]); + fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]); break; case 7: - fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]); + fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]); break; case 8: - fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]); + fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]); break; } - ST(0) = sv_newmortal(); - if (fp != NULL) { - GV *gv = newGVgen("VMS::stdio"); - c = mode[0]; name = mode; - if (mode[1]) *(name++) = '+'; - if (c == 'r') *(name++) = '<'; - else { - *(name++) = '>'; - if (c == 'a') *(name++) = '>'; - } - *(name++) = '&'; - if (do_open(gv,mode,name - mode,FALSE,0,0,fp)) - sv_setsv(ST(0),newRV((SV*)gv)); + if (fp != Nullfp) { + SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : '>'))); + ST(0) = (fh ? sv_2mortal(fh) : &sv_undef); } + else { ST(0) = &sv_undef; } -char * -fgetname(fp) - FILE * fp +void +vmssysopen(spec,mode,perm,...) + char * spec + int mode + int perm + PROTOTYPE: @ CODE: - char fname[257]; - ST(0) = sv_newmortal(); - if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname); + char *args[8]; + int i, myargc, fd; + FILE *fp; + SV *fh; + if (!spec || !*spec) { + SETERRNO(EINVAL,LIB$_INVARG); + XSRETURN_UNDEF; + } + if (items > 11) croak("too many args"); + myargc = items - 3; + for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),na); + /* More fun with C calls; can't combine with above because + args 2,3 of different types in fopen() and open() */ + switch (myargc) { + case 0: + fd = open(spec,mode,perm); + break; + case 1: + fd = open(spec,mode,perm,args[0]); + break; + case 2: + fd = open(spec,mode,perm,args[0],args[1]); + break; + case 3: + fd = open(spec,mode,perm,args[0],args[1],args[2]); + break; + case 4: + fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]); + break; + case 5: + fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]); + break; + case 6: + fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]); + break; + case 7: + fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]); + break; + case 8: + fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]); + break; + } + i = mode & 3; + if (fd >= 0 && + ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) { + SV *fh = newFH(fp,"<>++"[i]); + ST(0) = (fh ? sv_2mortal(fh) : &sv_undef); + } + else { ST(0) = &sv_undef; } -char * -tmpnam() +void +waitfh(fp) + FILE * fp + PROTOTYPE: $ CODE: - char fname[L_tmpnam]; - ST(0) = sv_newmortal(); - if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname); + ST(0) = fwait(fp) ? &sv_undef : &sv_yes;