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