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 } 460