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 = 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           s->obj = SvREFCNT_inc(result);
 139          else if (SvIV(result) != 0)
 140           return SvIV(result);
 141         }
 142        if (PerlIOVia_fetchmethod(aTHX_ s,MYMethod(FILL)) == (CV *) -1)
 143         PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
 144        else
 145         PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
 146       }
 147      else
 148       {
 149        Perl_warn(aTHX_ "Cannot find package '%.*s'",(int) pkglen,pkg);
 150        code = -1;
 151       }
 152     }
 153   }
 154  return code;
 155 }
 156
 157 PerlIO *
 158 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)
 159 {
 160  if (!f)
 161   {
 162    f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX),self,mode,PerlIOArg);
 163   }
 164  else
 165   {
 166    if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
 167     return NULL;
 168   }
 169  if (f)
 170   {
 171    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 172    SV *result = Nullsv;
 173    if (fd >= 0)
 174     {
 175      SV *fdsv = sv_2mortal(newSViv(fd));
 176      result = PerlIOVia_method(aTHX_ f,MYMethod(FDOPEN),G_SCALAR,fdsv,Nullsv);
 177     }
 178    else if (narg > 0)
 179     {
 180      if (*mode == '#')
 181       {
 182        SV *imodesv = sv_2mortal(newSViv(imode));
 183        SV *permsv  = sv_2mortal(newSViv(perm));
 184        result = PerlIOVia_method(aTHX_ f,MYMethod(SYSOPEN),G_SCALAR,*args,imodesv,permsv,Nullsv);
 185       }
 186      else
 187       {
 188        result = PerlIOVia_method(aTHX_ f,MYMethod(OPEN),G_SCALAR,*args,Nullsv);
 189       }
 190     }
 191    if (result)
 192     {
 193      if (sv_isobject(result))
 194       s->obj = SvREFCNT_inc(result);
 195      else if (!SvTRUE(result))
 196       {
 197        return NULL;
 198       }
 199     }
 200    else
 201     return NULL;
 202   }
 203  return f;
 204 }
 205
 206 IV
 207 PerlIOVia_popped(PerlIO *f)
 208 {
 209  dTHX;
 210  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 211  PerlIOVia_method(aTHX_ f,MYMethod(POPPED),G_VOID,Nullsv);
 212  if (s->var)
 213   {
 214    SvREFCNT_dec(s->var);
 215    s->var = Nullsv;
 216   }
 217
 218  if (s->io)
 219   {
 220    IoIFP(s->io) = NULL;
 221    IoOFP(s->io) = NULL;
 222   }
 223  if (s->fh)
 224   {
 225    SvREFCNT_dec(s->fh);
 226    s->fh  = Nullsv;
 227    s->io  = NULL;
 228   }
 229  if (s->obj)
 230   {
 231    SvREFCNT_dec(s->obj);
 232    s->obj = Nullsv;
 233   }
 234  return 0;
 235 }
 236
 237 IV
 238 PerlIOVia_close(PerlIO *f)
 239 {
 240  dTHX;
 241  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 242  IV code = PerlIOBase_close(f);
 243  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(CLOSE),G_SCALAR,Nullsv);
 244  if (result && SvIV(result) != 0)
 245   code = SvIV(result);
 246  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
 247  return code;
 248 }
 249
 250 IV
 251 PerlIOVia_fileno(PerlIO *f)
 252 {
 253  dTHX;
 254  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 255  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILENO),G_SCALAR,Nullsv);
 256  return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
 257 }
 258
 259 IV
 260 PerlIOVia_seek(PerlIO *f, Off_t offset, int whence)
 261 {
 262  dTHX;
 263  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 264  SV *offsv  = sv_2mortal(newSViv(offset));
 265  SV *whsv   = sv_2mortal(newSViv(offset));
 266  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
 267  return (result) ? SvIV(result) : -1;
 268 }
 269
 270 Off_t
 271 PerlIOVia_tell(PerlIO *f)
 272 {
 273  dTHX;
 274  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 275  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
 276  return (result) ? (Off_t) SvIV(result) : s->posn;
 277 }
 278
 279 SSize_t
 280 PerlIOVia_unread(PerlIO *f, const void *vbuf, Size_t count)
 281 {
 282  dTHX;
 283  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 284  SV *buf    = sv_2mortal(newSVpvn((char *)vbuf,count));
 285  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(UNREAD),G_SCALAR,buf,Nullsv);
 286  if (result)
 287   return (SSize_t) SvIV(result);
 288  else
 289   {
 290    return PerlIOBase_unread(f,vbuf,count);
 291   }
 292 }
 293
 294 SSize_t
 295 PerlIOVia_read(PerlIO *f, void *vbuf, Size_t count)
 296 {
 297  SSize_t rd = 0;
 298  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 299   {
 300    if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)
 301     {
 302      rd = PerlIOBase_read(f,vbuf,count);
 303     }
 304    else
 305     {
 306      dTHX;
 307      PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 308      SV *buf    = sv_2mortal(newSV(count));
 309      SV *n      = sv_2mortal(newSViv(count));
 310      SV *result = PerlIOVia_method(aTHX_ f,MYMethod(READ),G_SCALAR,buf,n,Nullsv);
 311      if (result)
 312       {
 313        rd = (SSize_t) SvIV(result);
 314        Move(SvPVX(buf),vbuf,rd,char);
 315        return rd;
 316       }
 317     }
 318   }
 319  return rd;
 320 }
 321
 322 SSize_t
 323 PerlIOVia_write(PerlIO *f, const void *vbuf, Size_t count)
 324 {
 325  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
 326   {
 327    dTHX;
 328    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 329    SV *buf    = newSVpvn((char *)vbuf,count);
 330    SV *result = PerlIOVia_method(aTHX_ f,MYMethod(WRITE),G_SCALAR,buf,Nullsv);
 331    SvREFCNT_dec(buf);
 332    if (result)
 333     return (SSize_t) SvIV(result);
 334    return -1;
 335   }
 336  return 0;
 337 }
 338
 339 IV
 340 PerlIOVia_fill(PerlIO *f)
 341 {
 342  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 343   {
 344    dTHX;
 345    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 346    SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILL),G_SCALAR,Nullsv);
 347    if (s->var)
 348     {
 349      SvREFCNT_dec(s->var);
 350      s->var = Nullsv;
 351     }
 352    if (result && SvOK(result))
 353     {
 354      STRLEN len = 0;
 355      char *p = SvPV(result,len);
 356      s->var = newSVpvn(p,len);
 357      s->cnt = SvCUR(s->var);
 358      return 0;
 359     }
 360    else
 361     PerlIOBase(f)->flags |= PERLIO_F_EOF;
 362   }
 363  return -1;
 364 }
 365
 366 IV
 367 PerlIOVia_flush(PerlIO *f)
 368 {
 369  dTHX;
 370  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 371  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FLUSH),G_SCALAR,Nullsv);
 372  if (s->var && s->cnt > 0)
 373   {
 374    SvREFCNT_dec(s->var);
 375    s->var = Nullsv;
 376   }
 377  return (result) ? SvIV(result) : 0;
 378 }
 379
 380 STDCHAR *
 381 PerlIOVia_get_base(PerlIO *f)
 382 {
 383  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 384   {
 385    dTHX;
 386    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 387    if (s->var)
 388     {
 389      return (STDCHAR *)SvPVX(s->var);
 390     }
 391   }
 392  return (STDCHAR *) Nullch;
 393 }
 394
 395 STDCHAR *
 396 PerlIOVia_get_ptr(PerlIO *f)
 397 {
 398  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 399   {
 400    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 401    if (s->var)
 402     {
 403      dTHX;
 404      STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
 405      return p;
 406     }
 407   }
 408  return (STDCHAR *) Nullch;
 409 }
 410
 411 SSize_t
 412 PerlIOVia_get_cnt(PerlIO *f)
 413 {
 414  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 415   {
 416    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 417    if (s->var)
 418     {
 419      return s->cnt;
 420     }
 421   }
 422  return 0;
 423 }
 424
 425 Size_t
 426 PerlIOVia_bufsiz(PerlIO *f)
 427 {
 428  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 429   {
 430    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 431    if (s->var)
 432     return SvCUR(s->var);
 433   }
 434  return 0;
 435 }
 436
 437 void
 438 PerlIOVia_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
 439 {
 440  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 441  s->cnt = cnt;
 442 }
 443
 444 void
 445 PerlIOVia_setlinebuf(PerlIO *f)
 446 {
 447  dTHX;
 448  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 449  PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
 450  PerlIOBase_setlinebuf(f);
 451 }
 452
 453 void
 454 PerlIOVia_clearerr(PerlIO *f)
 455 {
 456  dTHX;
 457  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 458  PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
 459  PerlIOBase_clearerr(f);
 460 }
 461
 462 SV *
 463 PerlIOVia_getarg(PerlIO *f)
 464 {
 465  dTHX;
 466  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 467  return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
 468 }
 469
 470 IV
 471 PerlIOVia_error(PerlIO *f)
 472 {
 473  dTHX;
 474  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 475  SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
 476  return (result) ? SvIV(result) : PerlIOBase_error(f);
 477 }
 478
 479 IV
 480 PerlIOVia_eof(PerlIO *f)
 481 {
 482  dTHX;
 483  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 484  SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
 485  return (result) ? SvIV(result) : PerlIOBase_eof(f);
 486 }
 487
 488 PerlIO_funcs PerlIO_object = {
 489  "Via",
 490  sizeof(PerlIOVia),
 491  PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
 492  PerlIOVia_pushed,
 493  PerlIOVia_popped,
 494  NULL, /* PerlIOVia_open, */
 495  PerlIOVia_getarg,
 496  PerlIOVia_fileno,
 497  PerlIOVia_read,
 498  PerlIOVia_unread,
 499  PerlIOVia_write,
 500  PerlIOVia_seek,
 501  PerlIOVia_tell,
 502  PerlIOVia_close,
 503  PerlIOVia_flush,
 504  PerlIOVia_fill,
 505  PerlIOVia_eof,
 506  PerlIOVia_error,
 507  PerlIOVia_clearerr,
 508  PerlIOVia_setlinebuf,
 509  PerlIOVia_get_base,
 510  PerlIOVia_bufsiz,
 511  PerlIOVia_get_ptr,
 512  PerlIOVia_get_cnt,
 513  PerlIOVia_set_ptrcnt,
 514 };
 515
 516
 517 #endif /* Layers available */
 518
 519 MODULE = PerlIO::Via    PACKAGE = PerlIO::Via
 520 PROTOTYPES: ENABLE;
 521
 522 BOOT:
 523 {
 524 #ifdef PERLIO_LAYERS
 525  PerlIO_define_layer(aTHX_ &PerlIO_object);
 526 #endif
 527 }
 528