ext/VMS-Stdio/Stdio.xs

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