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