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