vms/ext/Stdio/Stdio.xs

   1 /* VMS::Stdio - VMS extensions to stdio routines
   2  *
   3  * Version:  2.02
   4  * Author:   Charles Bailey  bailey@genetics.upenn.edu
   5  * Revised:  15-Feb-1997
   6  *
   7  */
   8
   9 #include "EXTERN.h"
  10 #include "perl.h"
  11 #include "XSUB.h"
  12 #include <file.h>
  13
  14 static bool
  15 constant(name, pval)
  16 char *name;
  17 IV *pval;
  18 {
  19     if (strnNE(name, "O_", 2)) return FALSE;
  20
  21     if (strEQ(name, "O_APPEND"))
  22 #ifdef O_APPEND
  23         { *pval = O_APPEND; return TRUE; }
  24 #else
  25         return FALSE;
  26 #endif
  27     if (strEQ(name, "O_CREAT"))
  28 #ifdef O_CREAT
  29         { *pval = O_CREAT; return TRUE; }
  30 #else
  31         return FALSE;
  32 #endif
  33     if (strEQ(name, "O_EXCL"))
  34 #ifdef O_EXCL
  35         { *pval = O_EXCL; return TRUE; }
  36 #else
  37         return FALSE;
  38 #endif
  39     if (strEQ(name, "O_NDELAY"))
  40 #ifdef O_NDELAY
  41         { *pval = O_NDELAY; return TRUE; }
  42 #else
  43         return FALSE;
  44 #endif
  45     if (strEQ(name, "O_NOWAIT"))
  46 #ifdef O_NOWAIT
  47         { *pval = O_NOWAIT; return TRUE; }
  48 #else
  49         return FALSE;
  50 #endif
  51     if (strEQ(name, "O_RDONLY"))
  52 #ifdef O_RDONLY
  53         { *pval = O_RDONLY; return TRUE; }
  54 #else
  55         return FALSE;
  56 #endif
  57     if (strEQ(name, "O_RDWR"))
  58 #ifdef O_RDWR
  59         { *pval = O_RDWR; return TRUE; }
  60 #else
  61         return FALSE;
  62 #endif
  63     if (strEQ(name, "O_TRUNC"))
  64 #ifdef O_TRUNC
  65         { *pval = O_TRUNC; return TRUE; }
  66 #else
  67         return FALSE;
  68 #endif
  69     if (strEQ(name, "O_WRONLY"))
  70 #ifdef O_WRONLY
  71         { *pval = O_WRONLY; return TRUE; }
  72 #else
  73         return FALSE;
  74 #endif
  75
  76     return FALSE;
  77 }
  78
  79
  80 static SV *
  81 newFH(FILE *fp, char type) {
  82     SV *rv;
  83     GV **stashp, *gv = (GV *)NEWSV(0,0);
  84     HV *stash;
  85     IO *io;
  86
  87     /* Find stash for VMS::Stdio.  We don't do this once at boot
  88      * to allow for possibility of threaded Perl with per-thread
  89      * symbol tables.  This code (through io = ...) is really
  90      * equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO),
  91      * with a little less overhead, and good exercise for me. :-) */
  92     stashp = (GV **)hv_fetch(defstash,"VMS::",5,TRUE);
  93     if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv;
  94     if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
  95     stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE);
  96     if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv;
  97     if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
  98
  99     /* Set up GV to point to IO, and then take reference */
 100     gv_init(gv,stash,"__FH__",6,0);
 101     io = GvIOp(gv) = newIO();
 102     IoIFP(io) = fp;
 103     if (type != '<') IoOFP(io) = fp;
 104     IoTYPE(io) = type;
 105     rv = newRV((SV *)gv);
 106     SvREFCNT_dec(gv);
 107     return sv_bless(rv,stash);
 108 }
 109
 110 MODULE = VMS::Stdio  PACKAGE = VMS::Stdio
 111
 112 void
 113 constant(name)
 114         char *  name
 115         PROTOTYPE: $
 116         CODE:
 117         IV i;
 118         if (constant(name, &i))
 119             ST(0) = sv_2mortal(newSViv(i));
 120         else
 121             ST(0) = &sv_undef;
 122
 123 void
 124 flush(sv)
 125         SV *    sv
 126         PROTOTYPE: $
 127         CODE:
 128             FILE *fp = Nullfp;
 129             if (SvOK(sv)) fp = IoIFP(sv_2io(sv));
 130             if (fflush(fp)) { ST(0) = &sv_undef; }
 131             else            { clearerr(fp); ST(0) = &sv_yes; }
 132
 133 char *
 134 getname(fp)
 135         FILE *  fp
 136         PROTOTYPE: $
 137         CODE:
 138             char fname[257];
 139             ST(0) = sv_newmortal();
 140             if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
 141
 142 void
 143 rewind(fp)
 144         FILE *  fp
 145         PROTOTYPE: $
 146         CODE:
 147             ST(0) = rewind(fp) ? &sv_undef : &sv_yes;
 148
 149 void
 150 remove(name)
 151         char *name
 152         PROTOTYPE: $
 153         CODE:
 154             ST(0) = remove(name) ? &sv_undef : &sv_yes;
 155
 156 void
 157 sync(fp)
 158         FILE *  fp
 159         PROTOTYPE: $
 160         CODE:
 161             if (fsync(fileno(fp))) { ST(0) = &sv_undef; }
 162             else                   { clearerr(fp); ST(0) = &sv_yes; }
 163
 164 char *
 165 tmpnam()
 166         PROTOTYPE:
 167         CODE:
 168             char fname[L_tmpnam];
 169             ST(0) = sv_newmortal();
 170             if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
 171
 172 void
 173 vmsopen(spec,...)
 174         char *  spec
 175         PROTOTYPE: @
 176         CODE:
 177             char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
 178             register int i, myargc;
 179             FILE *fp;
 180
 181             if (!spec || !*spec) {
 182                SETERRNO(EINVAL,LIB$_INVARG);
 183                XSRETURN_UNDEF;
 184             }
 185             if (items > 9) croak("too many args");
 186
 187             /* First, set up name and mode args from perl's string */
 188             if (*spec == '+') {
 189               mode[1] = '+';
 190               spec++;
 191             }
 192             if (*spec == '>') {
 193               if (*(spec+1) == '>') *mode = 'a', spec += 2;
 194               else *mode = 'w',  spec++;
 195             }
 196             else if (*spec == '<') spec++;
 197             myargc = items - 1;
 198             for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),na);
 199             /* This hack brought to you by C's opaque arglist management */
 200             switch (myargc) {
 201               case 0:
 202                 fp = fopen(spec,mode);
 203                 break;
 204               case 1:
 205                 fp = fopen(spec,mode,args[0]);
 206                 break;
 207               case 2:
 208                 fp = fopen(spec,mode,args[0],args[1]);
 209                 break;
 210               case 3:
 211                 fp = fopen(spec,mode,args[0],args[1],args[2]);
 212                 break;
 213               case 4:
 214                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
 215                 break;
 216               case 5:
 217                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
 218                 break;
 219               case 6:
 220                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
 221                 break;
 222               case 7:
 223                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
 224                 break;
 225               case 8:
 226                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
 227                 break;
 228             }
 229             if (fp != Nullfp) {
 230               SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
 231               ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
 232             }
 233             else { ST(0) = &sv_undef; }
 234
 235 void
 236 vmssysopen(spec,mode,perm,...)
 237         char *  spec
 238         int     mode
 239         int     perm
 240         PROTOTYPE: @
 241         CODE:
 242             char *args[8];
 243             int i, myargc, fd;
 244             FILE *fp;
 245             SV *fh;
 246             if (!spec || !*spec) {
 247                SETERRNO(EINVAL,LIB$_INVARG);
 248                XSRETURN_UNDEF;
 249             }
 250             if (items > 11) croak("too many args");
 251             myargc = items - 3;
 252             for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),na);
 253             /* More fun with C calls; can't combine with above because
 254                args 2,3 of different types in fopen() and open() */
 255             switch (myargc) {
 256               case 0:
 257                 fd = open(spec,mode,perm);
 258                 break;
 259               case 1:
 260                 fd = open(spec,mode,perm,args[0]);
 261                 break;
 262               case 2:
 263                 fd = open(spec,mode,perm,args[0],args[1]);
 264                 break;
 265               case 3:
 266                 fd = open(spec,mode,perm,args[0],args[1],args[2]);
 267                 break;
 268               case 4:
 269                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]);
 270                 break;
 271               case 5:
 272                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]);
 273                 break;
 274               case 6:
 275                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]);
 276                 break;
 277               case 7:
 278                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
 279                 break;
 280               case 8:
 281                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
 282                 break;
 283             }
 284             i = mode & 3;
 285             if (fd >= 0 &&
 286                ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) {
 287               SV *fh = newFH(fp,"<>++"[i]);
 288               ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
 289             }
 290             else { ST(0) = &sv_undef; }
 291
 292 void
 293 waitfh(fp)
 294         FILE *  fp
 295         PROTOTYPE: $
 296         CODE:
 297             ST(0) = fwait(fp) ? &sv_undef : &sv_yes;