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 #include "EXTERN.h"
   8 #include "perl.h"
   9 #include "XSUB.h"
  10 #include <file.h>
  11 #include <iodef.h>
  12 #include <rms.h>
  13 #include <starlet.h>
  14
  15 static bool
  16 constant(char *name, IV *pval)
  17 {
  18     if (strnNE(name, "O_", 2)) return FALSE;
  19
  20     if (strEQ(name, "O_APPEND"))
  21 #ifdef O_APPEND
  22         { *pval = O_APPEND; return TRUE; }
  23 #else
  24         return FALSE;
  25 #endif
  26     if (strEQ(name, "O_CREAT"))
  27 #ifdef O_CREAT
  28         { *pval = O_CREAT; return TRUE; }
  29 #else
  30         return FALSE;
  31 #endif
  32     if (strEQ(name, "O_EXCL"))
  33 #ifdef O_EXCL
  34         { *pval = O_EXCL; return TRUE; }
  35 #else
  36         return FALSE;
  37 #endif
  38     if (strEQ(name, "O_NDELAY"))
  39 #ifdef O_NDELAY
  40         { *pval = O_NDELAY; return TRUE; }
  41 #else
  42         return FALSE;
  43 #endif
  44     if (strEQ(name, "O_NOWAIT"))
  45 #ifdef O_NOWAIT
  46         { *pval = O_NOWAIT; return TRUE; }
  47 #else
  48         return FALSE;
  49 #endif
  50     if (strEQ(name, "O_RDONLY"))
  51 #ifdef O_RDONLY
  52         { *pval = O_RDONLY; return TRUE; }
  53 #else
  54         return FALSE;
  55 #endif
  56     if (strEQ(name, "O_RDWR"))
  57 #ifdef O_RDWR
  58         { *pval = O_RDWR; return TRUE; }
  59 #else
  60         return FALSE;
  61 #endif
  62     if (strEQ(name, "O_TRUNC"))
  63 #ifdef O_TRUNC
  64         { *pval = O_TRUNC; return TRUE; }
  65 #else
  66         return FALSE;
  67 #endif
  68     if (strEQ(name, "O_WRONLY"))
  69 #ifdef O_WRONLY
  70         { *pval = O_WRONLY; return TRUE; }
  71 #else
  72         return FALSE;
  73 #endif
  74
  75     return FALSE;
  76 }
  77
  78
  79 static SV *
  80 newFH(PerlIO *fp, char type) {
  81     SV *rv;
  82     GV **stashp, *gv = (GV *)newSV(0);
  83     HV *stash;
  84     IO *io;
  85
  86     /* Find stash for VMS::Stdio.  We don't do this once at boot
  87      * to allow for possibility of threaded Perl with per-thread
  88      * symbol tables.  This code (through io = ...) is really
  89      * equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO),
  90      * with a little less overhead, and good exercise for me. :-) */
  91     stashp = (GV **)hv_fetch(PL_defstash,"VMS::",5,TRUE);
  92     if (!stashp || *stashp == (GV *)&PL_sv_undef) return NULL;
  93     if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
  94     stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE);
  95     if (!stashp || *stashp == (GV *)&PL_sv_undef) return NULL;
  96     if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
  97
  98     /* Set up GV to point to IO, and then take reference */
  99     gv_init(gv,stash,"__FH__",6,0);
 100     io = GvIOp(gv) = newIO();
 101     IoIFP(io) = fp;
 102     if (type != '<') IoOFP(io) = fp;
 103     IoTYPE(io) = type;
 104     rv = newRV((SV *)gv);
 105     SvREFCNT_dec(gv);
 106     return sv_bless(rv,stash);
 107 }
 108
 109 MODULE = VMS::Stdio  PACKAGE = VMS::Stdio
 110
 111 void
 112 constant(name)
 113         char *  name
 114         PROTOTYPE: $
 115         CODE:
 116         IV i;
 117         if (constant(name, &i))
 118             ST(0) = sv_2mortal(newSViv(i));
 119         else
 120             ST(0) = &PL_sv_undef;
 121
 122 void
 123 binmode(fh)
 124         SV *    fh
 125         PROTOTYPE: $
 126         CODE:
 127            SV *name;
 128            IO *io;
 129            char iotype;
 130            char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = NULL;
 131            int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
 132            SV pos;
 133            PerlIO *fp;
 134            io = sv_2io(fh);
 135            fp = io ? IoOFP(io) : NULL;
 136            iotype = io ? IoTYPE(io) : '\0';
 137             if (fp == NULL || strchr(">was+-|",iotype) == NULL) {
 138               set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
 139             }
 140            if (!PerlIO_getname(fp,filespec)) XSRETURN_UNDEF;
 141             for (s = filespec; *s; s++) {
 142               if (*s == ':') colon = s;
 143               else if (*s == ']' || *s == '>') dirend = s;
 144             }
 145             /* Looks like a tmpfile, which will go away if reopened */
 146             if (s == dirend + 3) {
 147               set_errno(EBADF); set_vaxc_errno(RMS$_IOP); XSRETURN_UNDEF;
 148             }
 149             /* If we've got a non-file-structured device, clip off the trailing
 150              * junk, and don't lose sleep if we can't get a stream position.  */
 151             if (dirend == NULL) *(colon+1) = '\0';
 152            if (iotype != '-' && (ret = PerlIO_getpos(fp, &pos)) == -1 && dirend)
 153               XSRETURN_UNDEF;
 154             switch (iotype) {
 155               case '<': case 'r':           acmode = "rb";                      break;
 156               case '>': case 'w': case '|':
 157                 /* use 'a' instead of 'w' to avoid creating new file;
 158                    fsetpos below will take care of restoring file position */
 159               case 'a':                     acmode = "ab";                      break;
 160               case '+':  case 's':          acmode = "rb+";                     break;
 161              case '-':                     acmode = PerlIO_fileno(fp) ? "ab" : "rb";  break;
 162               /* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
 163               /* since we didn't really open them and can't really */
 164               /* reopen them */
 165               case 0:                       XSRETURN_UNDEF;
 166               default:
 167                 if (PL_dowarn) warn("Unrecognized iotype %c for %s in binmode",
 168                                  iotype, filespec);
 169                 acmode = "rb+";
 170             }
 171            /* appearances to the contrary, this is an freopen substitute */
 172            name = sv_2mortal(newSVpvn(filespec,strlen(filespec)));
 173            if (PerlIO_openn(aTHX_ NULL,acmode,-1,0,0,fp,1,&name) == NULL) XSRETURN_UNDEF;
 174            if (iotype != '-' && ret != -1 && PerlIO_setpos(fp,&pos) == -1) XSRETURN_UNDEF;
 175             if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
 176             XSRETURN_YES;
 177
 178
 179 void
 180 flush(fp)
 181        PerlIO * fp
 182         PROTOTYPE: $
 183         CODE:
 184            FILE *stdio = PerlIO_exportFILE(fp,0);
 185            if (fflush(stdio)) { ST(0) = &PL_sv_undef; }
 186            else            { clearerr(stdio); ST(0) = &PL_sv_yes; }
 187            PerlIO_releaseFILE(fp,stdio);
 188
 189 char *
 190 getname(fp)
 191         PerlIO * fp
 192         PROTOTYPE: $
 193         CODE:
 194             FILE *stdio = PerlIO_exportFILE(fp,0);
 195             char fname[NAM$C_MAXRSS+1];
 196             ST(0) = sv_newmortal();
 197             if (fgetname(stdio,fname) != NULL) sv_setpv(ST(0),fname);
 198             PerlIO_releaseFILE(fp,stdio);
 199
 200 void
 201 rewind(fp)
 202        PerlIO * fp
 203         PROTOTYPE: $
 204         CODE:
 205            FILE *stdio = PerlIO_exportFILE(fp,0);
 206            ST(0) = rewind(stdio) ? &PL_sv_undef : &PL_sv_yes;
 207            PerlIO_releaseFILE(fp,stdio);
 208
 209 void
 210 remove(name)
 211         char *name
 212         PROTOTYPE: $
 213         CODE:
 214             ST(0) = remove(name) ? &PL_sv_undef : &PL_sv_yes;
 215
 216 void
 217 setdef(...)
 218         PROTOTYPE: @
 219         CODE:
 220             char vmsdef[NAM$C_MAXRSS+1], es[NAM$C_MAXRSS], sep;
 221             unsigned long int retsts;
 222             struct FAB deffab = cc$rms_fab;
 223             struct NAM defnam = cc$rms_nam;
 224             struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 225             STRLEN n_a;
 226             if (items) {
 227                 SV *defsv = ST(items-1);  /* mimic chdir() */
 228                 ST(0) = &PL_sv_undef;
 229                 if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); }
 230                 if (tovmsspec(SvPV(defsv,n_a),vmsdef) == NULL) { XSRETURN(1); }
 231                 deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef);
 232             }
 233             else {
 234                 deffab.fab$l_fna = "SYS$LOGIN"; deffab.fab$b_fns = 9;
 235                 EXTEND(sp,1);  ST(0) = &PL_sv_undef;
 236             }
 237             defnam.nam$l_esa = es;  defnam.nam$b_ess = sizeof es;
 238             deffab.fab$l_nam = &defnam;
 239             retsts = sys$parse(&deffab,0,0);
 240             if (retsts & 1) {
 241                 if (defnam.nam$v_wildcard) retsts = RMS$_WLD;
 242                 else if (defnam.nam$b_name || defnam.nam$b_type > 1 ||
 243                      defnam.nam$b_ver > 1) retsts = RMS$_DIR;
 244                 }
 245             defnam.nam$b_nop |= NAM$M_SYNCHK; defnam.nam$l_rlf = NULL; deffab.fab$b_dns = 0;
 246             if (!(retsts & 1)) {
 247                 set_vaxc_errno(retsts);
 248                 switch (retsts) {
 249                     case RMS$_DNF:
 250                         set_errno(ENOENT); break;
 251                     case RMS$_SYN: case RMS$_DIR: case RMS$_DEV:
 252                         set_errno(EINVAL); break;
 253                     case RMS$_PRV:
 254                         set_errno(EACCES); break;
 255                     default:
 256                         set_errno(EVMSERR); break;
 257                 }
 258                 (void) sys$parse(&deffab,0,0);  /* free up context */
 259                 XSRETURN(1);
 260             }
 261             sep = *defnam.nam$l_dir;
 262             *defnam.nam$l_dir = '\0';
 263             my_setenv("SYS$DISK",defnam.nam$b_node ? defnam.nam$l_node : defnam.nam$l_dev);
 264             *defnam.nam$l_dir = sep;
 265             dirdsc.dsc$a_pointer = defnam.nam$l_dir; dirdsc.dsc$w_length = defnam.nam$b_dir;
 266             if ((retsts = sys$setddir(&dirdsc,0,0)) & 1) ST(0) = &PL_sv_yes;
 267             else { set_errno(EVMSERR); set_vaxc_errno(retsts); }
 268             (void) sys$parse(&deffab,0,0);  /* free up context */
 269
 270 void
 271 sync(fp)
 272        PerlIO * fp
 273         PROTOTYPE: $
 274         CODE:
 275            FILE *stdio = PerlIO_exportFILE(fp,0);
 276            if (fsync(fileno(stdio))) { ST(0) = &PL_sv_undef; }
 277            else                   { clearerr(stdio); ST(0) = &PL_sv_yes; }
 278            PerlIO_releaseFILE(fp,stdio);
 279
 280 char *
 281 tmpnam()
 282         PROTOTYPE:
 283         CODE:
 284             char fname[L_tmpnam];
 285             ST(0) = sv_newmortal();
 286             if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
 287
 288 void
 289 vmsopen(spec,...)
 290         char *  spec
 291         PROTOTYPE: @
 292         CODE:
 293             char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
 294             int i, myargc;
 295             FILE *fp;
 296             SV *fh;
 297            PerlIO *pio_fp;
 298             STRLEN n_a;
 299
 300             if (!spec || !*spec) {
 301                SETERRNO(EINVAL,LIB$_INVARG);
 302                XSRETURN_UNDEF;
 303             }
 304             if (items > 9) croak("too many args");
 305
 306             /* First, set up name and mode args from perl's string */
 307             if (*spec == '+') {
 308               mode[1] = '+';
 309               spec++;
 310             }
 311             if (*spec == '>') {
 312               if (*(spec+1) == '>') *mode = 'a', spec += 2;
 313               else *mode = 'w',  spec++;
 314             }
 315             else if (*spec == '<') spec++;
 316             myargc = items - 1;
 317             for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),n_a);
 318             /* This hack brought to you by C's opaque arglist management */
 319             switch (myargc) {
 320               case 0:
 321                 fp = fopen(spec,mode);
 322                 break;
 323               case 1:
 324                 fp = fopen(spec,mode,args[0]);
 325                 break;
 326               case 2:
 327                 fp = fopen(spec,mode,args[0],args[1]);
 328                 break;
 329               case 3:
 330                 fp = fopen(spec,mode,args[0],args[1],args[2]);
 331                 break;
 332               case 4:
 333                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
 334                 break;
 335               case 5:
 336                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
 337                 break;
 338               case 6:
 339                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
 340                 break;
 341               case 7:
 342                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
 343                 break;
 344               case 8:
 345                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
 346                 break;
 347             }
 348             if (fp != NULL) {
 349              pio_fp = PerlIO_fdopen(fileno(fp),mode);
 350              fh = newFH(pio_fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
 351              ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
 352             }
 353             else { ST(0) = &PL_sv_undef; }
 354
 355 void
 356 vmssysopen(spec,mode,perm,...)
 357         char *  spec
 358         int     mode
 359         int     perm
 360         PROTOTYPE: @
 361         CODE:
 362             char *args[8];
 363             int i, myargc, fd;
 364             PerlIO *pio_fp;
 365             SV *fh;
 366             STRLEN n_a;
 367             if (!spec || !*spec) {
 368                SETERRNO(EINVAL,LIB$_INVARG);
 369                XSRETURN_UNDEF;
 370             }
 371             if (items > 11) croak("too many args");
 372             myargc = items - 3;
 373             for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),n_a);
 374             /* More fun with C calls; can't combine with above because
 375                args 2,3 of different types in fopen() and open() */
 376             switch (myargc) {
 377               case 0:
 378                 fd = open(spec,mode,perm);
 379                 break;
 380               case 1:
 381                 fd = open(spec,mode,perm,args[0]);
 382                 break;
 383               case 2:
 384                 fd = open(spec,mode,perm,args[0],args[1]);
 385                 break;
 386               case 3:
 387                 fd = open(spec,mode,perm,args[0],args[1],args[2]);
 388                 break;
 389               case 4:
 390                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]);
 391                 break;
 392               case 5:
 393                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]);
 394                 break;
 395               case 6:
 396                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]);
 397                 break;
 398               case 7:
 399                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
 400                 break;
 401               case 8:
 402                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
 403                 break;
 404             }
 405             i = mode & 3;
 406             if (fd >= 0 &&
 407               ((pio_fp = PerlIO_fdopen(fd, &("r\000w\000r+"[2*i]))) != NULL)) {
 408              fh = newFH(pio_fp,"<>++"[i]);
 409              ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
 410             }
 411             else { ST(0) = &PL_sv_undef; }
 412
 413 void
 414 waitfh(fp)
 415        PerlIO * fp
 416         PROTOTYPE: $
 417         CODE:
 418            FILE *stdio = PerlIO_exportFILE(fp,0);
 419            ST(0) = fwait(stdio) ? &PL_sv_undef : &PL_sv_yes;
 420            PerlIO_releaseFILE(fp,stdio);
 421
 422 void
 423 writeof(mysv)
 424         SV *    mysv
 425         PROTOTYPE: $
 426         CODE:
 427             char devnam[257], *cp;
 428             unsigned long int chan, iosb[2], retsts, retsts2;
 429             struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
 430             IO *io = sv_2io(mysv);
 431            PerlIO *fp = io ? IoOFP(io) : NULL;
 432             if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == NULL) {
 433               set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
 434             }
 435            if (PerlIO_getname(fp,devnam) == NULL) { ST(0) = &PL_sv_undef; XSRETURN(1); }
 436             if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
 437             devdsc.dsc$w_length = strlen(devnam);
 438             retsts = sys$assign(&devdsc,&chan,0,0);
 439             if (retsts & 1) retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
 440             if (retsts & 1) retsts = iosb[0];
 441             retsts2 = sys$dassgn(chan);  /* Be sure to deassign the channel */
 442             if (retsts & 1) retsts = retsts2;
 443             if (retsts & 1) { ST(0) = &PL_sv_yes; }
 444             else {
 445               set_vaxc_errno(retsts);
 446               switch (retsts) {
 447                 case SS$_EXQUOTA:  case SS$_INSFMEM:  case SS$_MBFULL:
 448                 case SS$_MBTOOSML: case SS$_NOIOCHAN: case SS$_NOLINKS:
 449                 case SS$_BUFFEROVF:
 450                   set_errno(ENOSPC); break;
 451                 case SS$_ILLIOFUNC: case SS$_DEVOFFLINE: case SS$_NOSUCHDEV:
 452                   set_errno(EBADF);  break;
 453                 case SS$_NOPRIV:
 454                   set_errno(EACCES); break;
 455                 default:  /* Includes "shouldn't happen" cases that might map */
 456                   set_errno(EVMSERR); break;         /* to other errno values */
 457               }
 458               ST(0) = &PL_sv_undef;
 459             }