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