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