vms/ext/Stdio/Stdio.xs

   1 /* VMS::Stdio - VMS extensions to stdio routines
   2  *
   3  * Version:  2.1
   4  * Author:   Charles Bailey  bailey@genetics.upenn.edu
   5  * Revised:  24-Mar-1998
   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(FILE *fp, char type) {
  85     SV *rv;
  86     GV **stashp, *gv = (GV *)NEWSV(0,0);
  87     HV *stash;
  88     IO *io;
  89
  90     dTHR;
  91     /* Find stash for VMS::Stdio.  We don't do this once at boot
  92      * to allow for possibility of threaded Perl with per-thread
  93      * symbol tables.  This code (through io = ...) is really
  94      * equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO),
  95      * with a little less overhead, and good exercise for me. :-) */
  96     stashp = (GV **)hv_fetch(defstash,"VMS::",5,TRUE);
  97     if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv;
  98     if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
  99     stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE);
 100     if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv;
 101     if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
 102
 103     /* Set up GV to point to IO, and then take reference */
 104     gv_init(gv,stash,"__FH__",6,0);
 105     io = GvIOp(gv) = newIO();
 106     IoIFP(io) = fp;
 107     if (type != '<') IoOFP(io) = fp;
 108     IoTYPE(io) = type;
 109     rv = newRV((SV *)gv);
 110     SvREFCNT_dec(gv);
 111     return sv_bless(rv,stash);
 112 }
 113
 114 MODULE = VMS::Stdio  PACKAGE = VMS::Stdio
 115
 116 void
 117 constant(name)
 118         char *  name
 119         PROTOTYPE: $
 120         CODE:
 121         IV i;
 122         if (constant(name, &i))
 123             ST(0) = sv_2mortal(newSViv(i));
 124         else
 125             ST(0) = &sv_undef;
 126
 127 void
 128 flush(fp)
 129         FILE *  fp
 130         PROTOTYPE: $
 131         CODE:
 132             if (fflush(fp)) { ST(0) = &sv_undef; }
 133             else            { clearerr(fp); ST(0) = &sv_yes; }
 134
 135 char *
 136 getname(fp)
 137         FILE *  fp
 138         PROTOTYPE: $
 139         CODE:
 140             char fname[NAM$C_MAXRSS+1];
 141             ST(0) = sv_newmortal();
 142             if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
 143
 144 void
 145 rewind(fp)
 146         FILE *  fp
 147         PROTOTYPE: $
 148         CODE:
 149             ST(0) = rewind(fp) ? &sv_undef : &sv_yes;
 150
 151 void
 152 remove(name)
 153         char *name
 154         PROTOTYPE: $
 155         CODE:
 156             ST(0) = remove(name) ? &sv_undef : &sv_yes;
 157
 158 void
 159 setdef(...)
 160         PROTOTYPE: @
 161         CODE:
 162             char vmsdef[NAM$C_MAXRSS+1], es[NAM$C_MAXRSS], sep;
 163             unsigned long int retsts;
 164             struct FAB deffab = cc$rms_fab;
 165             struct NAM defnam = cc$rms_nam;
 166             struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
 167             if (items) {
 168                 SV *defsv = ST(items-1);  /* mimic chdir() */
 169                 ST(0) = &sv_undef;
 170                 if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); }
 171                 if (tovmsspec(SvPV(defsv,na),vmsdef) == NULL) { XSRETURN(1); }
 172                 deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef);
 173             }
 174             else {
 175                 deffab.fab$l_fna = "SYS$LOGIN"; deffab.fab$b_fns = 9;
 176                 EXTEND(sp,1);  ST(0) = &sv_undef;
 177             }
 178             defnam.nam$l_esa = es;  defnam.nam$b_ess = sizeof es;
 179             deffab.fab$l_nam = &defnam;
 180             retsts = sys$parse(&deffab,0,0);
 181             if (retsts & 1) {
 182                 if (defnam.nam$v_wildcard) retsts = RMS$_WLD;
 183                 else if (defnam.nam$b_name || defnam.nam$b_type > 1 ||
 184                      defnam.nam$b_ver > 1) retsts = RMS$_DIR;
 185                 }
 186             defnam.nam$b_nop |= NAM$M_SYNCHK; defnam.nam$l_rlf = NULL; deffab.fab$b_dns = 0;
 187             if (!(retsts & 1)) {
 188                 set_vaxc_errno(retsts);
 189                 switch (retsts) {
 190                     case RMS$_DNF:
 191                         set_errno(ENOENT); break;
 192                     case RMS$_SYN: case RMS$_DIR: case RMS$_DEV:
 193                         set_errno(EINVAL); break;
 194                     case RMS$_PRV:
 195                         set_errno(EACCES); break;
 196                     default:
 197                         set_errno(EVMSERR); break;
 198                 }
 199                 (void) sys$parse(&deffab,0,0);  /* free up context */
 200                 XSRETURN(1);
 201             }
 202             sep = *defnam.nam$l_dir;
 203             *defnam.nam$l_dir = '\0';
 204             my_setenv("SYS$DISK",defnam.nam$b_node ? defnam.nam$l_node : defnam.nam$l_dev);
 205             *defnam.nam$l_dir = sep;
 206             dirdsc.dsc$a_pointer = defnam.nam$l_dir; dirdsc.dsc$w_length = defnam.nam$b_dir;
 207             if ((retsts = sys$setddir(&dirdsc,0,0)) & 1) ST(0) = &sv_yes;
 208             else { set_errno(EVMSERR); set_vaxc_errno(retsts); }
 209             (void) sys$parse(&deffab,0,0);  /* free up context */
 210
 211 void
 212 sync(fp)
 213         FILE *  fp
 214         PROTOTYPE: $
 215         CODE:
 216             if (fsync(fileno(fp))) { ST(0) = &sv_undef; }
 217             else                   { clearerr(fp); ST(0) = &sv_yes; }
 218
 219 char *
 220 tmpnam()
 221         PROTOTYPE:
 222         CODE:
 223             char fname[L_tmpnam];
 224             ST(0) = sv_newmortal();
 225             if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
 226
 227 void
 228 vmsopen(spec,...)
 229         char *  spec
 230         PROTOTYPE: @
 231         CODE:
 232             char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
 233             register int i, myargc;
 234             FILE *fp;
 235
 236             if (!spec || !*spec) {
 237                SETERRNO(EINVAL,LIB$_INVARG);
 238                XSRETURN_UNDEF;
 239             }
 240             if (items > 9) croak("too many args");
 241
 242             /* First, set up name and mode args from perl's string */
 243             if (*spec == '+') {
 244               mode[1] = '+';
 245               spec++;
 246             }
 247             if (*spec == '>') {
 248               if (*(spec+1) == '>') *mode = 'a', spec += 2;
 249               else *mode = 'w',  spec++;
 250             }
 251             else if (*spec == '<') spec++;
 252             myargc = items - 1;
 253             for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),na);
 254             /* This hack brought to you by C's opaque arglist management */
 255             switch (myargc) {
 256               case 0:
 257                 fp = fopen(spec,mode);
 258                 break;
 259               case 1:
 260                 fp = fopen(spec,mode,args[0]);
 261                 break;
 262               case 2:
 263                 fp = fopen(spec,mode,args[0],args[1]);
 264                 break;
 265               case 3:
 266                 fp = fopen(spec,mode,args[0],args[1],args[2]);
 267                 break;
 268               case 4:
 269                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
 270                 break;
 271               case 5:
 272                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
 273                 break;
 274               case 6:
 275                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
 276                 break;
 277               case 7:
 278                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
 279                 break;
 280               case 8:
 281                 fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
 282                 break;
 283             }
 284             if (fp != Nullfp) {
 285               SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
 286               ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
 287             }
 288             else { ST(0) = &sv_undef; }
 289
 290 void
 291 vmssysopen(spec,mode,perm,...)
 292         char *  spec
 293         int     mode
 294         int     perm
 295         PROTOTYPE: @
 296         CODE:
 297             char *args[8];
 298             int i, myargc, fd;
 299             FILE *fp;
 300             SV *fh;
 301             if (!spec || !*spec) {
 302                SETERRNO(EINVAL,LIB$_INVARG);
 303                XSRETURN_UNDEF;
 304             }
 305             if (items > 11) croak("too many args");
 306             myargc = items - 3;
 307             for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),na);
 308             /* More fun with C calls; can't combine with above because
 309                args 2,3 of different types in fopen() and open() */
 310             switch (myargc) {
 311               case 0:
 312                 fd = open(spec,mode,perm);
 313                 break;
 314               case 1:
 315                 fd = open(spec,mode,perm,args[0]);
 316                 break;
 317               case 2:
 318                 fd = open(spec,mode,perm,args[0],args[1]);
 319                 break;
 320               case 3:
 321                 fd = open(spec,mode,perm,args[0],args[1],args[2]);
 322                 break;
 323               case 4:
 324                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]);
 325                 break;
 326               case 5:
 327                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]);
 328                 break;
 329               case 6:
 330                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]);
 331                 break;
 332               case 7:
 333                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
 334                 break;
 335               case 8:
 336                 fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
 337                 break;
 338             }
 339             i = mode & 3;
 340             if (fd >= 0 &&
 341                ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) {
 342               SV *fh = newFH(fp,"<>++"[i]);
 343               ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
 344             }
 345             else { ST(0) = &sv_undef; }
 346
 347 void
 348 waitfh(fp)
 349         FILE *  fp
 350         PROTOTYPE: $
 351         CODE:
 352             ST(0) = fwait(fp) ? &sv_undef : &sv_yes;
 353
 354 void
 355 writeof(mysv)
 356         SV *    mysv
 357         PROTOTYPE: $
 358         CODE:
 359             char devnam[257], *cp;
 360             unsigned long int chan, iosb[2], retsts, retsts2;
 361             struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
 362             IO *io = sv_2io(mysv);
 363             FILE *fp = io ? IoOFP(io) : NULL;
 364             if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) {
 365               set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN);
 366               ST(0) = &sv_undef;  XSRETURN(1);
 367             }
 368             if (fgetname(fp,devnam) == Nullch) { ST(0) = &sv_undef; XSRETURN(1); }
 369             if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
 370             devdsc.dsc$w_length = strlen(devnam);
 371             retsts = sys$assign(&devdsc,&chan,0,0);
 372             if (retsts & 1) retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
 373             if (retsts & 1) retsts = iosb[0];
 374             retsts2 = sys$dassgn(chan);  /* Be sure to deassign the channel */
 375             if (retsts & 1) retsts = retsts2;
 376             if (retsts & 1) { ST(0) = &sv_yes; }
 377             else {
 378               set_vaxc_errno(retsts);
 379               switch (retsts) {
 380                 case SS$_EXQUOTA:  case SS$_INSFMEM:  case SS$_MBFULL:
 381                 case SS$_MBTOOSML: case SS$_NOIOCHAN: case SS$_NOLINKS:
 382                 case SS$_BUFFEROVF:
 383                   set_errno(ENOSPC); break;
 384                 case SS$_ILLIOFUNC: case SS$_DEVOFFLINE: case SS$_NOSUCHDEV:
 385                   set_errno(EBADF);  break;
 386                 case SS$_NOPRIV:
 387                   set_errno(EACCES); break;
 388                 default:  /* Includes "shouldn't happen" cases that might map */
 389                   set_errno(EVMSERR); break;         /* to other errno values */
 390               }
 391               ST(0) = &sv_undef;
 392             }