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 || memCHRs(">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 || memCHRs(">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 } 463