ext/PerlIO-via/via.xs

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