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