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