vms/ext/Stdio/Stdio.xs

   1 /* VMS::Stdio - VMS extensions to stdio routines
   2  *
   3  * Version:  2.0
   4  * Author:   Charles Bailey  bailey@genetics.upenn.edu
   5  * Revised:  28-Feb-1996
   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             ST(0) = fflush(fp) ? &sv_undef : &sv_yes;
 131
 132 char *
 133 getname(fp)
 134         FILE *  fp
 135         PROTOTYPE: $
 136         CODE:
 137             char fname[257];
 138             ST(0) = sv_newmortal();
 139             if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
 140
 141 void
 142 rewind(fp)
 143         FILE *  fp
 144         PROTOTYPE: $
 145         CODE:
 146             ST(0) = rewind(fp) ? &sv_undef : &sv_yes;
 147
 148 void
 149 remove(name)
 150         char *name
 151         PROTOTYPE: $
 152         CODE:
 153             ST(0) = remove(name) ? &sv_undef : &sv_yes;
 154
 155 void
 156 sync(fp)
 157         FILE *  fp
 158         PROTOTYPE: $
 159         CODE:
 160             ST(0) = fsync(fileno(fp)) ? &sv_undef : &sv_yes;
 161
 162 char *
 163 tmpnam()
 164         PROTOTYPE:
 165         CODE:
 166             char fname[L_tmpnam];
 167             ST(0) = sv_newmortal();
 168             if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
 169
 170 void
 171 vmsopen(spec,...)
 172         char *  spec
 173         PROTOTYPE: @
 174         CODE:
 175             char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
 176             register int i, myargc;
 177             FILE *fp;
 178
 179             if (!spec || !*spec) {
 180                SETERRNO(EINVAL,LIB$_INVARG);
 181                XSRETURN_UNDEF;
 182             }
 183             if (items > 9) croak("too many args");
 184
 185             /* First, set up name and mode args from perl's string */
 186             if (*spec == '+') {
 187               mode[1] = '+';
 188               spec++;
 189             }
 190             if (*spec == '>') {
 191               if (*(spec+1) == '>') *mode = 'a', spec += 2;
 192               else *mode = 'w',  spec++;
 193             }
 194             else if (*spec == '<') spec++;
 195             myargc = items - 1;
 196             for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),na);
 197             /* This hack brought to you by C's opaque arglist management */
 198             switch (myargc) {
 199               case 0:
 200                 fp = fopen(spec,mode);
 201                 break;
 202               case 1:
 203                 fp = fopen(spec,mode,args[0]);
 204                 break;
 205               case 2:
 206                 fp = fopen(spec,mode,args[0],args[1]);
 207                 break;
 208               case 3:
 209                 fp = fopen(spec,mode,args[0],args[1],args[2]);
 210                 break;
 211               case 4:
 212                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
 213                 break;
 214               case 5:
 215                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
 216                 break;
 217               case 6:
 218                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
 219                 break;
 220               case 7:
 221                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
 222                 break;
 223               case 8:
 224                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
 225                 break;
 226             }
 227             if (fp != Nullfp) {
 228               SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
 229               ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
 230             }
 231             else { ST(0) = &sv_undef; }
 232
 233 void
 234 vmssysopen(spec,mode,perm,...)
 235         char *  spec
 236         int     mode
 237         int     perm
 238         PROTOTYPE: @
 239         CODE:
 240             char *args[8];
 241             int i, myargc, fd;
 242             FILE *fp;
 243             SV *fh;
 244             if (!spec || !*spec) {
 245                SETERRNO(EINVAL,LIB$_INVARG);
 246                XSRETURN_UNDEF;
 247             }
 248             if (items > 11) croak("too many args");
 249             myargc = items - 3;
 250             for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),na);
 251             /* More fun with C calls; can't combine with above because
 252                args 2,3 of different types in fopen() and open() */
 253             switch (myargc) {
 254               case 0:
 255                 fd = open(spec,mode,perm);
 256                 break;
 257               case 1:
 258                 fd = open(spec,mode,perm,args[0]);
 259                 break;
 260               case 2:
 261                 fd = open(spec,mode,perm,args[0],args[1]);
 262                 break;
 263               case 3:
 264                 fd = open(spec,mode,perm,args[0],args[1],args[2]);
 265                 break;
 266               case 4:
 267                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]);
 268                 break;
 269               case 5:
 270                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]);
 271                 break;
 272               case 6:
 273                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]);
 274                 break;
 275               case 7:
 276                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
 277                 break;
 278               case 8:
 279                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
 280                 break;
 281             }
 282             i = mode & 3;
 283             if (fd >= 0 &&
 284                ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) {
 285               SV *fh = newFH(fp,"<>++"[i]);
 286               ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
 287             }
 288             else { ST(0) = &sv_undef; }
 289
 290 void
 291 waitfh(fp)
 292         FILE *  fp
 293         PROTOTYPE: $
 294         CODE:
 295             ST(0) = fwait(fp) ? &sv_undef : &sv_yes;