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