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