ext/VMS-Stdio/Stdio.xs

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