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  Off_t          posn;
  17  IO *           io;
  18  SV *           fh;
  19  CV *PUSHED;
  20  CV *POPPED;
  21  CV *OPEN;
  22  CV *FDOPEN;
  23  CV *SYSOPEN;
  24  CV *GETARG;
  25  CV *FILENO;
  26  CV *READ;
  27  CV *WRITE;
  28  CV *FILL;
  29  CV *CLOSE;
  30  CV *SEEK;
  31  CV *TELL;
  32  CV *UNREAD;
  33  CV *FLUSH;
  34  CV *SETLINEBUF;
  35  CV *CLEARERR;
  36  CV *mERROR;
  37  CV *mEOF;
  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 SV *
  61 PerlIOVia_method(pTHX_ PerlIO *f,char *method,CV **save,int flags,...)
  62 {
  63  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
  64  CV *cv = (*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s,method,save);
  65  SV *result = Nullsv;
  66  va_list ap;
  67  va_start(ap,flags);
  68  if (cv != (CV *)-1)
  69   {
  70    IV count;
  71    dSP;
  72    SV *arg;
  73    int i = 0;
  74    ENTER;
  75    PUSHMARK(sp);
  76    XPUSHs(s->obj);
  77    while ((arg = va_arg(ap,SV *)))
  78     {
  79      XPUSHs(arg);
  80     }
  81    if (*PerlIONext(f))
  82     {
  83      if (!s->fh)
  84       {
  85        GV *gv = newGVgen(HvNAME(s->stash));
  86        GvIOp(gv) = newIO();
  87        s->fh  = newRV_noinc((SV *)gv);
  88        s->io  = GvIOp(gv);
  89       }
  90      IoIFP(s->io) = PerlIONext(f);
  91      IoOFP(s->io) = PerlIONext(f);
  92      XPUSHs(s->fh);
  93     }
  94    PUTBACK;
  95    count = call_sv((SV *)cv,flags);
  96    if (count)
  97     {
  98      SPAGAIN;
  99      result = POPs;
 100      PUTBACK;
 101     }
 102    else
 103     {
 104      result = &PL_sv_undef;
 105     }
 106    LEAVE;
 107   }
 108  va_end(ap);
 109  return result;
 110 }
 111
 112 IV
 113 PerlIOVia_pushed(PerlIO *f, const char *mode, SV *arg)
 114 {
 115  IV code = PerlIOBase_pushed(f,mode,Nullsv);
 116  if (code == 0)
 117   {
 118    dTHX;
 119    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 120    if (!arg)
 121     {
 122      Perl_warn(aTHX_ "No package specified");
 123      code = -1;
 124     }
 125    else
 126     {
 127      STRLEN pkglen = 0;
 128      char *pkg = SvPV(arg,pkglen);
 129      s->obj = SvREFCNT_inc(arg);
 130      s->stash  = gv_stashpvn(pkg, pkglen, FALSE);
 131      if (s->stash)
 132       {
 133        SV *modesv = (mode) ? sv_2mortal(newSVpvn(mode,strlen(mode))) : Nullsv;
 134        SV *result = PerlIOVia_method(aTHX_ f,MYMethod(PUSHED),G_SCALAR,modesv,Nullsv);
 135        if (result)
 136         {
 137          if (sv_isobject(result))
 138           {
 139            s->obj = SvREFCNT_inc(result);
 140            SvREFCNT_dec(arg);
 141           }
 142          else if (SvIV(result) != 0)
 143           return SvIV(result);
 144         }
 145        if (PerlIOVia_fetchmethod(aTHX_ s,MYMethod(FILL)) == (CV *) -1)
 146         PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
 147        else
 148         PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
 149       }
 150      else
 151       {
 152        Perl_warn(aTHX_ "Cannot find package '%.*s'",(int) pkglen,pkg);
 153 #ifdef ENOSYS
 154        errno = ENOSYS;
 155 #else
 156 #ifdef ENOENT
 157        errno = ENOENT;
 158 #endif
 159 #endif
 160        code = -1;
 161       }
 162     }
 163   }
 164  return code;
 165 }
 166
 167 PerlIO *
 168 PerlIOVia_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
 169 {
 170  if (!f)
 171   {
 172    f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX),self,mode,PerlIOArg);
 173   }
 174  else
 175   {
 176    if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
 177     return NULL;
 178   }
 179  if (f)
 180   {
 181    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 182    SV *result = Nullsv;
 183    if (fd >= 0)
 184     {
 185      SV *fdsv = sv_2mortal(newSViv(fd));
 186      result = PerlIOVia_method(aTHX_ f,MYMethod(FDOPEN),G_SCALAR,fdsv,Nullsv);
 187     }
 188    else if (narg > 0)
 189     {
 190      if (*mode == '#')
 191       {
 192        SV *imodesv = sv_2mortal(newSViv(imode));
 193        SV *permsv  = sv_2mortal(newSViv(perm));
 194        result = PerlIOVia_method(aTHX_ f,MYMethod(SYSOPEN),G_SCALAR,*args,imodesv,permsv,Nullsv);
 195       }
 196      else
 197       {
 198        result = PerlIOVia_method(aTHX_ f,MYMethod(OPEN),G_SCALAR,*args,Nullsv);
 199       }
 200     }
 201    if (result)
 202     {
 203      if (sv_isobject(result))
 204       s->obj = SvREFCNT_inc(result);
 205      else if (!SvTRUE(result))
 206       {
 207        return NULL;
 208       }
 209     }
 210    else
 211     return NULL;
 212   }
 213  return f;
 214 }
 215
 216 IV
 217 PerlIOVia_popped(PerlIO *f)
 218 {
 219  dTHX;
 220  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 221  PerlIOVia_method(aTHX_ f,MYMethod(POPPED),G_VOID,Nullsv);
 222  if (s->var)
 223   {
 224    SvREFCNT_dec(s->var);
 225    s->var = Nullsv;
 226   }
 227
 228  if (s->io)
 229   {
 230    IoIFP(s->io) = NULL;
 231    IoOFP(s->io) = NULL;
 232   }
 233  if (s->fh)
 234   {
 235    SvREFCNT_dec(s->fh);
 236    s->fh  = Nullsv;
 237    s->io  = NULL;
 238   }
 239  if (s->obj)
 240   {
 241    SvREFCNT_dec(s->obj);
 242    s->obj = Nullsv;
 243   }
 244  return 0;
 245 }
 246
 247 IV
 248 PerlIOVia_close(PerlIO *f)
 249 {
 250  dTHX;
 251  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 252  IV code = PerlIOBase_close(f);
 253  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(CLOSE),G_SCALAR,Nullsv);
 254  if (result && SvIV(result) != 0)
 255   code = SvIV(result);
 256  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
 257  return code;
 258 }
 259
 260 IV
 261 PerlIOVia_fileno(PerlIO *f)
 262 {
 263  dTHX;
 264  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 265  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILENO),G_SCALAR,Nullsv);
 266  return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
 267 }
 268
 269 IV
 270 PerlIOVia_seek(PerlIO *f, Off_t offset, int whence)
 271 {
 272  dTHX;
 273  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 274  SV *offsv  = sv_2mortal(newSViv(offset));
 275  SV *whsv   = sv_2mortal(newSViv(offset));
 276  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
 277  return (result) ? SvIV(result) : -1;
 278 }
 279
 280 Off_t
 281 PerlIOVia_tell(PerlIO *f)
 282 {
 283  dTHX;
 284  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 285  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
 286  return (result) ? (Off_t) SvIV(result) : s->posn;
 287 }
 288
 289 SSize_t
 290 PerlIOVia_unread(PerlIO *f, const void *vbuf, Size_t count)
 291 {
 292  dTHX;
 293  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 294  SV *buf    = sv_2mortal(newSVpvn((char *)vbuf,count));
 295  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(UNREAD),G_SCALAR,buf,Nullsv);
 296  if (result)
 297   return (SSize_t) SvIV(result);
 298  else
 299   {
 300    return PerlIOBase_unread(f,vbuf,count);
 301   }
 302 }
 303
 304 SSize_t
 305 PerlIOVia_read(PerlIO *f, void *vbuf, Size_t count)
 306 {
 307  SSize_t rd = 0;
 308  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 309   {
 310    if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)
 311     {
 312      rd = PerlIOBase_read(f,vbuf,count);
 313     }
 314    else
 315     {
 316      dTHX;
 317      PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 318      SV *buf    = sv_2mortal(newSV(count));
 319      SV *n      = sv_2mortal(newSViv(count));
 320      SV *result = PerlIOVia_method(aTHX_ f,MYMethod(READ),G_SCALAR,buf,n,Nullsv);
 321      if (result)
 322       {
 323        rd = (SSize_t) SvIV(result);
 324        Move(SvPVX(buf),vbuf,rd,char);
 325        return rd;
 326       }
 327     }
 328   }
 329  return rd;
 330 }
 331
 332 SSize_t
 333 PerlIOVia_write(PerlIO *f, const void *vbuf, Size_t count)
 334 {
 335  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
 336   {
 337    dTHX;
 338    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 339    SV *buf    = newSVpvn((char *)vbuf,count);
 340    SV *result = PerlIOVia_method(aTHX_ f,MYMethod(WRITE),G_SCALAR,buf,Nullsv);
 341    SvREFCNT_dec(buf);
 342    if (result)
 343     return (SSize_t) SvIV(result);
 344    return -1;
 345   }
 346  return 0;
 347 }
 348
 349 IV
 350 PerlIOVia_fill(PerlIO *f)
 351 {
 352  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 353   {
 354    dTHX;
 355    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 356    SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILL),G_SCALAR,Nullsv);
 357    if (s->var)
 358     {
 359      SvREFCNT_dec(s->var);
 360      s->var = Nullsv;
 361     }
 362    if (result && SvOK(result))
 363     {
 364      STRLEN len = 0;
 365      char *p = SvPV(result,len);
 366      s->var = newSVpvn(p,len);
 367      s->cnt = SvCUR(s->var);
 368      return 0;
 369     }
 370    else
 371     PerlIOBase(f)->flags |= PERLIO_F_EOF;
 372   }
 373  return -1;
 374 }
 375
 376 IV
 377 PerlIOVia_flush(PerlIO *f)
 378 {
 379  dTHX;
 380  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 381  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FLUSH),G_SCALAR,Nullsv);
 382  if (s->var && s->cnt > 0)
 383   {
 384    SvREFCNT_dec(s->var);
 385    s->var = Nullsv;
 386   }
 387  return (result) ? SvIV(result) : 0;
 388 }
 389
 390 STDCHAR *
 391 PerlIOVia_get_base(PerlIO *f)
 392 {
 393  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 394   {
 395    dTHX;
 396    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 397    if (s->var)
 398     {
 399      return (STDCHAR *)SvPVX(s->var);
 400     }
 401   }
 402  return (STDCHAR *) Nullch;
 403 }
 404
 405 STDCHAR *
 406 PerlIOVia_get_ptr(PerlIO *f)
 407 {
 408  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 409   {
 410    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 411    if (s->var)
 412     {
 413      dTHX;
 414      STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
 415      return p;
 416     }
 417   }
 418  return (STDCHAR *) Nullch;
 419 }
 420
 421 SSize_t
 422 PerlIOVia_get_cnt(PerlIO *f)
 423 {
 424  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 425   {
 426    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 427    if (s->var)
 428     {
 429      return s->cnt;
 430     }
 431   }
 432  return 0;
 433 }
 434
 435 Size_t
 436 PerlIOVia_bufsiz(PerlIO *f)
 437 {
 438  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 439   {
 440    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 441    if (s->var)
 442     return SvCUR(s->var);
 443   }
 444  return 0;
 445 }
 446
 447 void
 448 PerlIOVia_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
 449 {
 450  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 451  s->cnt = cnt;
 452 }
 453
 454 void
 455 PerlIOVia_setlinebuf(PerlIO *f)
 456 {
 457  dTHX;
 458  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 459  PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
 460  PerlIOBase_setlinebuf(f);
 461 }
 462
 463 void
 464 PerlIOVia_clearerr(PerlIO *f)
 465 {
 466  dTHX;
 467  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 468  PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
 469  PerlIOBase_clearerr(f);
 470 }
 471
 472 SV *
 473 PerlIOVia_getarg(PerlIO *f)
 474 {
 475  dTHX;
 476  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 477  return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
 478 }
 479
 480 IV
 481 PerlIOVia_error(PerlIO *f)
 482 {
 483  dTHX;
 484  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 485  SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
 486  return (result) ? SvIV(result) : PerlIOBase_error(f);
 487 }
 488
 489 IV
 490 PerlIOVia_eof(PerlIO *f)
 491 {
 492  dTHX;
 493  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 494  SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
 495  return (result) ? SvIV(result) : PerlIOBase_eof(f);
 496 }
 497
 498 PerlIO_funcs PerlIO_object = {
 499  "Via",
 500  sizeof(PerlIOVia),
 501  PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
 502  PerlIOVia_pushed,
 503  PerlIOVia_popped,
 504  NULL, /* PerlIOVia_open, */
 505  PerlIOVia_getarg,
 506  PerlIOVia_fileno,
 507  PerlIOVia_read,
 508  PerlIOVia_unread,
 509  PerlIOVia_write,
 510  PerlIOVia_seek,
 511  PerlIOVia_tell,
 512  PerlIOVia_close,
 513  PerlIOVia_flush,
 514  PerlIOVia_fill,
 515  PerlIOVia_eof,
 516  PerlIOVia_error,
 517  PerlIOVia_clearerr,
 518  PerlIOVia_setlinebuf,
 519  PerlIOVia_get_base,
 520  PerlIOVia_bufsiz,
 521  PerlIOVia_get_ptr,
 522  PerlIOVia_get_cnt,
 523  PerlIOVia_set_ptrcnt,
 524 };
 525
 526
 527 #endif /* Layers available */
 528
 529 MODULE = PerlIO::Via    PACKAGE = PerlIO::Via
 530 PROTOTYPES: ENABLE;
 531
 532 BOOT:
 533 {
 534 #ifdef PERLIO_LAYERS
 535  PerlIO_define_layer(aTHX_ &PerlIO_object);
 536 #endif
 537 }
 538