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