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