1 #define PERL_NO_GET_CONTEXT 2 #include "EXTERN.h" 3 #include "perl.h" 4 #include "XSUB.h" 5 #ifdef PERLIO_LAYERS 6 7 #include "perliol.h" 8 9 typedef struct 10 { 11 struct _PerlIO base; /* Base "class" info */ 12 HV * stash; 13 SV * obj; 14 SV * var; 15 SSize_t cnt; 16 IO * io; 17 SV * fh; 18 CV *PUSHED; 19 CV *POPPED; 20 CV *OPEN; 21 CV *FDOPEN; 22 CV *SYSOPEN; 23 CV *GETARG; 24 CV *FILENO; 25 CV *READ; 26 CV *WRITE; 27 CV *FILL; 28 CV *CLOSE; 29 CV *SEEK; 30 CV *TELL; 31 CV *UNREAD; 32 CV *FLUSH; 33 CV *SETLINEBUF; 34 CV *CLEARERR; 35 CV *mERROR; 36 CV *mEOF; 37 CV *BINMODE; 38 CV *UTF8; 39 } PerlIOVia; 40 41 #define MYMethod(x) #x,&s->x 42 43 CV * 44 PerlIOVia_fetchmethod(pTHX_ PerlIOVia * s, const char *method, CV ** save) 45 { 46 GV *gv = gv_fetchmeth(s->stash, method, strlen(method), 0); 47 #if 0 48 Perl_warn(aTHX_ "Lookup %s::%s => %p", HvNAME_get(s->stash), method, gv); 49 #endif 50 if (gv) { 51 return *save = GvCV(gv); 52 } 53 else { 54 return *save = (CV *) - 1; 55 } 56 } 57 58 /* 59 * Try and call method, possibly via cached lookup. 60 * If method does not exist return Nullsv (caller may fallback to another approach 61 * If method does exist call it with flags passing variable number of args 62 * Last arg is a "filehandle" to layer below (if present) 63 * Returns scalar returned by method (if any) otherwise sv_undef 64 */ 65 66 SV * 67 PerlIOVia_method(pTHX_ PerlIO * f, const char *method, CV ** save, int flags, 68 ...) 69 { 70 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 71 SV *result = Nullsv; 72 CV *cv = 73 (*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s, method, save); 74 if (cv != (CV *) - 1) { 75 IV count; 76 dSP; 77 SV *arg; 78 va_list ap; 79 80 va_start(ap, flags); 81 PUSHSTACKi(PERLSI_MAGIC); 82 ENTER; 83 PUSHMARK(sp); 84 XPUSHs(s->obj); 85 while ((arg = va_arg(ap, SV *))) { 86 XPUSHs(arg); 87 } 88 va_end(ap); 89 if (*PerlIONext(f)) { 90 if (!s->fh) { 91 GV *gv; 92 char *package = HvNAME_get(s->stash); 93 94 if (!package) 95 return Nullsv; /* can this ever happen? */ 96 gv = newGVgen(package); 97 GvIOp(gv) = newIO(); 98 s->fh = newRV((SV *) gv); 99 s->io = GvIOp(gv); 100 if (gv) { 101 /* shamelessly stolen from IO::File's new_tmpfile() */ 102 (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); 103 } 104 } 105 IoIFP(s->io) = PerlIONext(f); 106 IoOFP(s->io) = PerlIONext(f); 107 XPUSHs(s->fh); 108 } 109 else { 110 PerlIO_debug("No next\n"); 111 /* FIXME: How should this work for OPEN etc? */ 112 } 113 PUTBACK; 114 count = call_sv((SV *) cv, flags); 115 if (count) { 116 SPAGAIN; 117 result = POPs; 118 PUTBACK; 119 } 120 else { 121 result = &PL_sv_undef; 122 } 123 LEAVE; 124 POPSTACK; 125 } 126 return result; 127 } 128 129 IV 130 PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, 131 PerlIO_funcs * tab) 132 { 133 IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab); 134 if (code == 0) { 135 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 136 if (!arg) { 137 if (ckWARN(WARN_LAYER)) 138 Perl_warner(aTHX_ packWARN(WARN_LAYER), 139 "No package specified"); 140 errno = EINVAL; 141 code = -1; 142 } 143 else { 144 STRLEN pkglen = 0; 145 const char *pkg = SvPV(arg, pkglen); 146 s->obj = 147 newSVpvn(Perl_form(aTHX_ "PerlIO::via::%s", pkg), 148 pkglen + 13); 149 s->stash = gv_stashpvn(SvPVX_const(s->obj), pkglen + 13, 0); 150 if (!s->stash) { 151 SvREFCNT_dec(s->obj); 152 s->obj = SvREFCNT_inc(arg); 153 s->stash = gv_stashpvn(pkg, pkglen, 0); 154 } 155 if (s->stash) { 156 char lmode[8]; 157 SV *modesv; 158 SV *result; 159 if (!mode) { 160 /* binmode() passes NULL - so find out what mode is */ 161 mode = PerlIO_modestr(f,lmode); 162 } 163 modesv = newSVpvn_flags(mode, strlen(mode), SVs_TEMP); 164 result = PerlIOVia_method(aTHX_ f, MYMethod(PUSHED), G_SCALAR, 165 modesv, Nullsv); 166 if (result) { 167 if (sv_isobject(result)) { 168 SvREFCNT_dec(s->obj); 169 s->obj = SvREFCNT_inc(result); 170 } 171 else if (SvIV(result) != 0) 172 return SvIV(result); 173 } 174 else { 175 goto push_failed; 176 } 177 modesv = (*PerlIONext(f) && (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_UTF8)) 178 ? &PL_sv_yes : &PL_sv_no; 179 result = PerlIOVia_method(aTHX_ f, MYMethod(UTF8), G_SCALAR, modesv, Nullsv); 180 if (result && SvTRUE(result)) { 181 PerlIOBase(f)->flags |= PERLIO_F_UTF8; 182 } 183 else { 184 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; 185 } 186 if (PerlIOVia_fetchmethod(aTHX_ s, MYMethod(FILL)) == 187 (CV *) - 1) 188 PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS; 189 else 190 PerlIOBase(f)->flags |= PERLIO_F_FASTGETS; 191 } 192 else { 193 if (ckWARN(WARN_LAYER)) 194 Perl_warner(aTHX_ packWARN(WARN_LAYER), 195 "Cannot find package '%.*s'", (int) pkglen, 196 pkg); 197 push_failed: 198 #ifdef ENOSYS 199 errno = ENOSYS; 200 #else 201 #ifdef ENOENT 202 errno = ENOENT; 203 #endif 204 #endif 205 code = -1; 206 } 207 } 208 } 209 return code; 210 } 211 212 PerlIO * 213 PerlIOVia_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, 214 IV n, const char *mode, int fd, int imode, int perm, 215 PerlIO * f, int narg, SV ** args) 216 { 217 if (!f) { 218 f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX), self, mode, 219 PerlIOArg); 220 } 221 else { 222 /* Reopen */ 223 if (!PerlIO_push(aTHX_ f, self, mode, PerlIOArg)) 224 return NULL; 225 } 226 if (f) { 227 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 228 SV *result = Nullsv; 229 if (fd >= 0) { 230 SV *fdsv = sv_2mortal(newSViv(fd)); 231 result = 232 PerlIOVia_method(aTHX_ f, MYMethod(FDOPEN), G_SCALAR, fdsv, 233 Nullsv); 234 } 235 else if (narg > 0) { 236 if (*mode == '#') { 237 SV *imodesv = sv_2mortal(newSViv(imode)); 238 SV *permsv = sv_2mortal(newSViv(perm)); 239 result = 240 PerlIOVia_method(aTHX_ f, MYMethod(SYSOPEN), G_SCALAR, 241 *args, imodesv, permsv, Nullsv); 242 } 243 else { 244 result = 245 PerlIOVia_method(aTHX_ f, MYMethod(OPEN), G_SCALAR, 246 *args, Nullsv); 247 } 248 } 249 if (result) { 250 if (sv_isobject(result)) 251 s->obj = SvREFCNT_inc(result); 252 else if (!SvTRUE(result)) { 253 return NULL; 254 } 255 } 256 else { 257 /* Required open method not present */ 258 PerlIO_funcs *tab = NULL; 259 IV m = n - 1; 260 while (m >= 0) { 261 PerlIO_funcs *t = 262 PerlIO_layer_fetch(aTHX_ layers, m, NULL); 263 if (t && t->Open) { 264 tab = t; 265 break; 266 } 267 m--; 268 } 269 if (tab) { 270 if ((*tab->Open) (aTHX_ tab, layers, m, mode, fd, imode, 271 perm, PerlIONext(f), narg, args)) { 272 PerlIO_debug("Opened with %s => %p->%p\n", tab->name, 273 PerlIONext(f), *PerlIONext(f)); 274 if (m + 1 < n) { 275 /* 276 * More layers above the one that we used to open - 277 * apply them now 278 */ 279 if (PerlIO_apply_layera 280 (aTHX_ PerlIONext(f), mode, layers, m + 1, 281 n) != 0) { 282 /* If pushing layers fails close the file */ 283 PerlIO_close(f); 284 f = NULL; 285 } 286 } 287 /* FIXME - Call an OPENED method here ? */ 288 return f; 289 } 290 else { 291 PerlIO_debug("Open fail %s => %p->%p\n", tab->name, 292 PerlIONext(f), *PerlIONext(f)); 293 /* Sub-layer open failed */ 294 } 295 } 296 else { 297 PerlIO_debug("Nothing to open with"); 298 /* Nothing to do the open */ 299 } 300 PerlIO_pop(aTHX_ f); 301 return NULL; 302 } 303 } 304 return f; 305 } 306 307 IV 308 PerlIOVia_popped(pTHX_ PerlIO * f) 309 { 310 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 311 PerlIOVia_method(aTHX_ f, MYMethod(POPPED), G_VOID, Nullsv); 312 if (s->var) { 313 SvREFCNT_dec(s->var); 314 s->var = Nullsv; 315 } 316 317 if (s->io) { 318 IoIFP(s->io) = NULL; 319 IoOFP(s->io) = NULL; 320 } 321 if (s->fh) { 322 SvREFCNT_dec(s->fh); 323 s->fh = Nullsv; 324 s->io = NULL; 325 } 326 if (s->obj) { 327 SvREFCNT_dec(s->obj); 328 s->obj = Nullsv; 329 } 330 return 0; 331 } 332 333 IV 334 PerlIOVia_close(pTHX_ PerlIO * f) 335 { 336 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 337 IV code = PerlIOBase_close(aTHX_ f); 338 SV *result = 339 PerlIOVia_method(aTHX_ f, MYMethod(CLOSE), G_SCALAR, Nullsv); 340 if (result && SvIV(result) != 0) 341 code = SvIV(result); 342 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 343 return code; 344 } 345 346 IV 347 PerlIOVia_fileno(pTHX_ PerlIO * f) 348 { 349 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 350 SV *result = 351 PerlIOVia_method(aTHX_ f, MYMethod(FILENO), G_SCALAR, Nullsv); 352 return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f)); 353 } 354 355 IV 356 PerlIOVia_binmode(pTHX_ PerlIO * f) 357 { 358 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 359 SV *result = 360 PerlIOVia_method(aTHX_ f, MYMethod(BINMODE), G_SCALAR, Nullsv); 361 if (!result || !SvOK(result)) { 362 PerlIO_pop(aTHX_ f); 363 return 0; 364 } 365 return SvIV(result); 366 } 367 368 IV 369 PerlIOVia_seek(pTHX_ PerlIO * f, Off_t offset, int whence) 370 { 371 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 372 SV *offsv = sv_2mortal(sizeof(Off_t) > sizeof(IV) 373 ? newSVnv((NV)offset) : newSViv((IV)offset)); 374 SV *whsv = sv_2mortal(newSViv(whence)); 375 SV *result = 376 PerlIOVia_method(aTHX_ f, MYMethod(SEEK), G_SCALAR, offsv, whsv, 377 Nullsv); 378 #if Off_t_size == 8 && defined(CONDOP_SIZE) && CONDOP_SIZE < Off_t_size 379 if (result) 380 return (Off_t) SvIV(result); 381 else 382 return (Off_t) -1; 383 #else 384 return (result) ? SvIV(result) : -1; 385 #endif 386 } 387 388 Off_t 389 PerlIOVia_tell(pTHX_ PerlIO * f) 390 { 391 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 392 SV *result = 393 PerlIOVia_method(aTHX_ f, MYMethod(TELL), G_SCALAR, Nullsv); 394 return (result) 395 ? (SvNOK(result) ? (Off_t)SvNV(result) : (Off_t)SvIV(result)) 396 : (Off_t) - 1; 397 } 398 399 SSize_t 400 PerlIOVia_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count) 401 { 402 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 403 SV *buf = newSVpvn_flags((char *) vbuf, count, SVs_TEMP); 404 SV *result = 405 PerlIOVia_method(aTHX_ f, MYMethod(UNREAD), G_SCALAR, buf, Nullsv); 406 if (result) 407 return (SSize_t) SvIV(result); 408 else { 409 return PerlIOBase_unread(aTHX_ f, vbuf, count); 410 } 411 } 412 413 SSize_t 414 PerlIOVia_read(pTHX_ PerlIO * f, void *vbuf, Size_t count) 415 { 416 SSize_t rd = 0; 417 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { 418 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) { 419 rd = PerlIOBase_read(aTHX_ f, vbuf, count); 420 } 421 else { 422 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 423 SV *buf = sv_2mortal(newSV(count)); 424 SV *n = sv_2mortal(newSViv(count)); 425 SV *result = 426 PerlIOVia_method(aTHX_ f, MYMethod(READ), G_SCALAR, buf, n, 427 Nullsv); 428 if (result) { 429 rd = (SSize_t) SvIV(result); 430 Move(SvPVX(buf), vbuf, rd, char); 431 return rd; 432 } 433 } 434 } 435 return rd; 436 } 437 438 SSize_t 439 PerlIOVia_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count) 440 { 441 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { 442 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 443 SV *buf = newSVpvn((char *) vbuf, count); 444 SV *result = 445 PerlIOVia_method(aTHX_ f, MYMethod(WRITE), G_SCALAR, buf, 446 Nullsv); 447 SvREFCNT_dec(buf); 448 if (result) 449 return (SSize_t) SvIV(result); 450 return -1; 451 } 452 return 0; 453 } 454 455 IV 456 PerlIOVia_fill(pTHX_ PerlIO * f) 457 { 458 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { 459 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 460 SV *result = 461 PerlIOVia_method(aTHX_ f, MYMethod(FILL), G_SCALAR, Nullsv); 462 if (s->var) { 463 SvREFCNT_dec(s->var); 464 s->var = Nullsv; 465 } 466 if (result && SvOK(result)) { 467 STRLEN len = 0; 468 const char *p = SvPV(result, len); 469 s->var = newSVpvn(p, len); 470 s->cnt = SvCUR(s->var); 471 return 0; 472 } 473 else 474 PerlIOBase(f)->flags |= PERLIO_F_EOF; 475 } 476 return -1; 477 } 478 479 IV 480 PerlIOVia_flush(pTHX_ PerlIO * f) 481 { 482 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 483 SV *result = 484 PerlIOVia_method(aTHX_ f, MYMethod(FLUSH), G_SCALAR, Nullsv); 485 if (s->var && s->cnt > 0) { 486 SvREFCNT_dec(s->var); 487 s->var = Nullsv; 488 } 489 return (result) ? SvIV(result) : 0; 490 } 491 492 STDCHAR * 493 PerlIOVia_get_base(pTHX_ PerlIO * f) 494 { 495 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { 496 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 497 if (s->var) { 498 return (STDCHAR *) SvPVX(s->var); 499 } 500 } 501 return (STDCHAR *) NULL; 502 } 503 504 STDCHAR * 505 PerlIOVia_get_ptr(pTHX_ PerlIO * f) 506 { 507 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { 508 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 509 if (s->var) { 510 STDCHAR *p = (STDCHAR *) (SvEND(s->var) - s->cnt); 511 return p; 512 } 513 } 514 return (STDCHAR *) NULL; 515 } 516 517 SSize_t 518 PerlIOVia_get_cnt(pTHX_ PerlIO * f) 519 { 520 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { 521 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 522 if (s->var) { 523 return s->cnt; 524 } 525 } 526 return 0; 527 } 528 529 Size_t 530 PerlIOVia_bufsiz(pTHX_ PerlIO * f) 531 { 532 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { 533 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 534 if (s->var) 535 return SvCUR(s->var); 536 } 537 return 0; 538 } 539 540 void 541 PerlIOVia_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt) 542 { 543 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 544 PERL_UNUSED_ARG(ptr); 545 s->cnt = cnt; 546 } 547 548 void 549 PerlIOVia_setlinebuf(pTHX_ PerlIO * f) 550 { 551 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 552 PerlIOVia_method(aTHX_ f, MYMethod(SETLINEBUF), G_VOID, Nullsv); 553 PerlIOBase_setlinebuf(aTHX_ f); 554 } 555 556 void 557 PerlIOVia_clearerr(pTHX_ PerlIO * f) 558 { 559 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 560 PerlIOVia_method(aTHX_ f, MYMethod(CLEARERR), G_VOID, Nullsv); 561 PerlIOBase_clearerr(aTHX_ f); 562 } 563 564 IV 565 PerlIOVia_error(pTHX_ PerlIO * f) 566 { 567 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 568 SV *result = 569 PerlIOVia_method(aTHX_ f, "ERROR", &s->mERROR, G_SCALAR, Nullsv); 570 return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f); 571 } 572 573 IV 574 PerlIOVia_eof(pTHX_ PerlIO * f) 575 { 576 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 577 SV *result = 578 PerlIOVia_method(aTHX_ f, "EOF", &s->mEOF, G_SCALAR, Nullsv); 579 return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f); 580 } 581 582 SV * 583 PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) 584 { 585 PerlIOVia *s = PerlIOSelf(f, PerlIOVia); 586 PERL_UNUSED_ARG(param); 587 PERL_UNUSED_ARG(flags); 588 return PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv); 589 } 590 591 PerlIO * 592 PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, 593 int flags) 594 { 595 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { 596 /* Most of the fields will lazily set themselves up as needed 597 stash and obj have been set up by the implied push 598 */ 599 } 600 return f; 601 } 602 603 604 605 PERLIO_FUNCS_DECL(PerlIO_object) = { 606 sizeof(PerlIO_funcs), 607 "via", 608 sizeof(PerlIOVia), 609 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT, 610 PerlIOVia_pushed, 611 PerlIOVia_popped, 612 PerlIOVia_open, /* NULL, */ 613 PerlIOVia_binmode, /* NULL, */ 614 PerlIOVia_getarg, 615 PerlIOVia_fileno, 616 PerlIOVia_dup, 617 PerlIOVia_read, 618 PerlIOVia_unread, 619 PerlIOVia_write, 620 PerlIOVia_seek, 621 PerlIOVia_tell, 622 PerlIOVia_close, 623 PerlIOVia_flush, 624 PerlIOVia_fill, 625 PerlIOVia_eof, 626 PerlIOVia_error, 627 PerlIOVia_clearerr, 628 PerlIOVia_setlinebuf, 629 PerlIOVia_get_base, 630 PerlIOVia_bufsiz, 631 PerlIOVia_get_ptr, 632 PerlIOVia_get_cnt, 633 PerlIOVia_set_ptrcnt, 634 }; 635 636 637 #endif /* Layers available */ 638 639 MODULE = PerlIO::via PACKAGE = PerlIO::via 640 PROTOTYPES: ENABLE; 641 642 BOOT: 643 { 644 #ifdef PERLIO_LAYERS 645 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_object)); 646 #endif 647 } 648 649 650 651 652 653