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