[p5sagit/p5-mst-13.2.git] / ext / PerlIO / Via / Via.xs

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef PERLIO_LAYERS

#include "perliol.h"

typedef struct
{
 struct _PerlIO base;       /* Base "class" info */
 HV *		stash;
 SV *		obj;
 SV *		var;
 SSize_t	cnt;
 Off_t		posn;
 IO *		io;
 SV *		fh;
 CV *PUSHED;
 CV *POPPED;
 CV *OPEN;
 CV *FDOPEN;
 CV *SYSOPEN;
 CV *GETARG;
 CV *FILENO;
 CV *READ;
 CV *WRITE;
 CV *FILL;
 CV *CLOSE;
 CV *SEEK;
 CV *TELL;
 CV *UNREAD;
 CV *FLUSH;
 CV *SETLINEBUF;
 CV *CLEARERR;
 CV *mERROR;
 CV *mEOF;
} PerlIOVia;

#define MYMethod(x) #x,&s->x

CV *
PerlIOVia_fetchmethod(pTHX_ PerlIOVia *s,char *method,CV **save)
{
 GV *gv = gv_fetchmeth(s->stash,method,strlen(method),0);
#if 0
 Perl_warn(aTHX_ "Lookup %s::%s => %p",HvNAME(s->stash),method,gv);
#endif
 if (gv)
  {
   return *save = GvCV(gv);
  }
 else
  {
   return *save = (CV *) -1;
  }

}

SV *
PerlIOVia_method(pTHX_ PerlIO *f,char *method,CV **save,int flags,...)
{
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 CV *cv = (*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s,method,save);
 SV *result = Nullsv;
 va_list ap;
 va_start(ap,flags);
 if (cv != (CV *)-1)
  {
   IV count;
   dSP;
   SV *arg;
   ENTER;
   PUSHMARK(sp);
   XPUSHs(s->obj);
   while ((arg = va_arg(ap,SV *)))
    {
     XPUSHs(arg);
    }
   if (*PerlIONext(f))
    {
     if (!s->fh)
      {
       GV *gv = newGVgen(HvNAME(s->stash));
       GvIOp(gv) = newIO();
       s->fh  = newRV_noinc((SV *)gv);
       s->io  = GvIOp(gv);
      }
     IoIFP(s->io) = PerlIONext(f);
     IoOFP(s->io) = PerlIONext(f);
     XPUSHs(s->fh);
    }
   PUTBACK;
   count = call_sv((SV *)cv,flags);
   if (count)
    {
     SPAGAIN;
     result = POPs;
     PUTBACK;
    }
   else
    {
     result = &PL_sv_undef;
    }
   LEAVE;
  }
 va_end(ap);
 return result;
}

IV
PerlIOVia_pushed(PerlIO *f, const char *mode, SV *arg)
{
 IV code = PerlIOBase_pushed(f,mode,Nullsv);
 if (code == 0)
  {
   dTHX;
   PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
   if (!arg)
    {
     Perl_warn(aTHX_ "No package specified");
     code = -1;
    }
   else
    {
     STRLEN pkglen = 0;
     char *pkg = SvPV(arg,pkglen);
     s->obj = SvREFCNT_inc(arg);
     s->stash  = gv_stashpvn(pkg, pkglen, FALSE);
     if (s->stash)
      {
       SV *modesv = (mode) ? sv_2mortal(newSVpvn(mode,strlen(mode))) : Nullsv;
       SV *result = PerlIOVia_method(aTHX_ f,MYMethod(PUSHED),G_SCALAR,modesv,Nullsv);
       if (result)
        {
         if (sv_isobject(result))
          {
           s->obj = SvREFCNT_inc(result);
           SvREFCNT_dec(arg);
          }
         else if (SvIV(result) != 0)
          return SvIV(result);
        }
       if (PerlIOVia_fetchmethod(aTHX_ s,MYMethod(FILL)) == (CV *) -1)
        PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
       else
        PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
      }
     else
      {
       Perl_warn(aTHX_ "Cannot find package '%.*s'",(int) pkglen,pkg);
#ifdef ENOSYS
       errno = ENOSYS;
#else
#ifdef ENOENT
       errno = ENOENT;
#endif
#endif
       code = -1;
      }
    }
  }
 return code;
}

PerlIO *
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)
{
 if (!f)
  {
   f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX),self,mode,PerlIOArg);
  }
 else
  {
   if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
    return NULL;
  }
 if (f)
  {
   PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
   SV *result = Nullsv;
   if (fd >= 0)
    {
     SV *fdsv = sv_2mortal(newSViv(fd));
     result = PerlIOVia_method(aTHX_ f,MYMethod(FDOPEN),G_SCALAR,fdsv,Nullsv);
    }
   else if (narg > 0)
    {
     if (*mode == '#')
      {
       SV *imodesv = sv_2mortal(newSViv(imode));
       SV *permsv  = sv_2mortal(newSViv(perm));
       result = PerlIOVia_method(aTHX_ f,MYMethod(SYSOPEN),G_SCALAR,*args,imodesv,permsv,Nullsv);
      }
     else
      {
       result = PerlIOVia_method(aTHX_ f,MYMethod(OPEN),G_SCALAR,*args,Nullsv);
      }
    }
   if (result)
    {
     if (sv_isobject(result))
      s->obj = SvREFCNT_inc(result);
     else if (!SvTRUE(result))
      {
       return NULL;
      }
    }
   else
    return NULL;
  }
 return f;
}

IV
PerlIOVia_popped(PerlIO *f)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 PerlIOVia_method(aTHX_ f,MYMethod(POPPED),G_VOID,Nullsv);
 if (s->var)
  {
   SvREFCNT_dec(s->var);
   s->var = Nullsv;
  }

 if (s->io)
  {
   IoIFP(s->io) = NULL;
   IoOFP(s->io) = NULL;
  }
 if (s->fh)
  {
   SvREFCNT_dec(s->fh);
   s->fh  = Nullsv;
   s->io  = NULL;
  }
 if (s->obj)
  {
   SvREFCNT_dec(s->obj);
   s->obj = Nullsv;
  }
 return 0;
}

IV
PerlIOVia_close(PerlIO *f)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 IV code = PerlIOBase_close(f);
 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(CLOSE),G_SCALAR,Nullsv);
 if (result && SvIV(result) != 0)
  code = SvIV(result);
 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
 return code;
}

IV
PerlIOVia_fileno(PerlIO *f)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILENO),G_SCALAR,Nullsv);
 return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
}

IV
PerlIOVia_seek(PerlIO *f, Off_t offset, int whence)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 SV *offsv  = sv_2mortal(newSViv(offset));
 SV *whsv   = sv_2mortal(newSViv(offset));
 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
 return (result) ? SvIV(result) : -1;
}

Off_t
PerlIOVia_tell(PerlIO *f)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
 return (result) ? (Off_t) SvIV(result) : s->posn;
}

SSize_t
PerlIOVia_unread(PerlIO *f, const void *vbuf, Size_t count)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 SV *buf    = sv_2mortal(newSVpvn((char *)vbuf,count));
 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(UNREAD),G_SCALAR,buf,Nullsv);
 if (result)
  return (SSize_t) SvIV(result);
 else
  {
   return PerlIOBase_unread(f,vbuf,count);
  }
}

SSize_t
PerlIOVia_read(PerlIO *f, void *vbuf, Size_t count)
{
 SSize_t rd = 0;
 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
  {
   if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)
    {
     rd = PerlIOBase_read(f,vbuf,count);
    }
   else
    {
     dTHX;
     PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
     SV *buf    = sv_2mortal(newSV(count));
     SV *n      = sv_2mortal(newSViv(count));
     SV *result = PerlIOVia_method(aTHX_ f,MYMethod(READ),G_SCALAR,buf,n,Nullsv);
     if (result)
      {
       rd = (SSize_t) SvIV(result);
       Move(SvPVX(buf),vbuf,rd,char);
       return rd;
      }
    }
  }
 return rd;
}

SSize_t
PerlIOVia_write(PerlIO *f, const void *vbuf, Size_t count)
{
 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
  {
   dTHX;
   PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
   SV *buf    = newSVpvn((char *)vbuf,count);
   SV *result = PerlIOVia_method(aTHX_ f,MYMethod(WRITE),G_SCALAR,buf,Nullsv);
   SvREFCNT_dec(buf);
   if (result)
    return (SSize_t) SvIV(result);
   return -1;
  }
 return 0;
}

IV
PerlIOVia_fill(PerlIO *f)
{
 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
  {
   dTHX;
   PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
   SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILL),G_SCALAR,Nullsv);
   if (s->var)
    {
     SvREFCNT_dec(s->var);
     s->var = Nullsv;
    }
   if (result && SvOK(result))
    {
     STRLEN len = 0;
     char *p = SvPV(result,len);
     s->var = newSVpvn(p,len);
     s->cnt = SvCUR(s->var);
     return 0;
    }
   else
    PerlIOBase(f)->flags |= PERLIO_F_EOF;
  }
 return -1;
}

IV
PerlIOVia_flush(PerlIO *f)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FLUSH),G_SCALAR,Nullsv);
 if (s->var && s->cnt > 0)
  {
   SvREFCNT_dec(s->var);
   s->var = Nullsv;
  }
 return (result) ? SvIV(result) : 0;
}

STDCHAR *
PerlIOVia_get_base(PerlIO *f)
{
 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
  {
   PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
   if (s->var)
    {
     return (STDCHAR *)SvPVX(s->var);
    }
  }
 return (STDCHAR *) Nullch;
}

STDCHAR *
PerlIOVia_get_ptr(PerlIO *f)
{
 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
  {
   PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
   if (s->var)
    {
     STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
     return p;
    }
  }
 return (STDCHAR *) Nullch;
}

SSize_t
PerlIOVia_get_cnt(PerlIO *f)
{
 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
  {
   PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
   if (s->var)
    {
     return s->cnt;
    }
  }
 return 0;
}

Size_t
PerlIOVia_bufsiz(PerlIO *f)
{
 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
  {
   PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
   if (s->var)
    return SvCUR(s->var);
  }
 return 0;
}

void
PerlIOVia_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
{
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 s->cnt = cnt;
}

void
PerlIOVia_setlinebuf(PerlIO *f)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
 PerlIOBase_setlinebuf(f);
}

void
PerlIOVia_clearerr(PerlIO *f)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
 PerlIOBase_clearerr(f);
}

SV *
PerlIOVia_getarg(PerlIO *f)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
}

IV
PerlIOVia_error(PerlIO *f)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
 return (result) ? SvIV(result) : PerlIOBase_error(f);
}

IV
PerlIOVia_eof(PerlIO *f)
{
 dTHX;
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
 return (result) ? SvIV(result) : PerlIOBase_eof(f);
}

PerlIO_funcs PerlIO_object = {
 "Via",
 sizeof(PerlIOVia),
 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
 PerlIOVia_pushed,
 PerlIOVia_popped,
 NULL, /* PerlIOVia_open, */
 PerlIOVia_getarg,
 PerlIOVia_fileno,
 PerlIOVia_read,
 PerlIOVia_unread,
 PerlIOVia_write,
 PerlIOVia_seek,
 PerlIOVia_tell,
 PerlIOVia_close,
 PerlIOVia_flush,
 PerlIOVia_fill,
 PerlIOVia_eof,
 PerlIOVia_error,
 PerlIOVia_clearerr,
 PerlIOVia_setlinebuf,
 PerlIOVia_get_base,
 PerlIOVia_bufsiz,
 PerlIOVia_get_ptr,
 PerlIOVia_get_cnt,
 PerlIOVia_set_ptrcnt,
};


#endif /* Layers available */

MODULE = PerlIO::Via	PACKAGE = PerlIO::Via
PROTOTYPES: ENABLE;

BOOT:
{
#ifdef PERLIO_LAYERS
 PerlIO_define_layer(aTHX_ &PerlIO_object);
#endif
}
Commit	Line	Data
e7a1fdd7	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;
c7997937	36	CV *mERROR;
e7a1fdd7	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;
e7a1fdd7	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);
267cbce7	128	s->obj = SvREFCNT_inc(arg);
e7a1fdd7	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))
267cbce7	137	{
	138	s->obj = SvREFCNT_inc(result);
	139	SvREFCNT_dec(arg);
	140	}
e7a1fdd7	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);
267cbce7	152	#ifdef ENOSYS
	153	errno = ENOSYS;
	154	#else
	155	#ifdef ENOENT
	156	errno = ENOENT;
	157	#endif
	158	#endif
e7a1fdd7	159	code = -1;
	160	}
	161	}
	162	}
	163	return code;
	164	}
	165
	166	PerlIO *
fcf2db38	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)
e7a1fdd7	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	{
e7a1fdd7	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	{
e7a1fdd7	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
c7997937	469	SV *
c7997937	470	PerlIOVia_getarg(PerlIO *f)
e7a1fdd7	471	{
	472	dTHX;
	473	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
c7997937	474	return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
e7a1fdd7	475	}
e7a1fdd7	476
c7997937	477	IV
c7997937	478	PerlIOVia_error(PerlIO *f)
e7a1fdd7	479	{
	480	dTHX;
	481	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
c7997937	482	SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
c7997937	483	return (result) ? SvIV(result) : PerlIOBase_error(f);
e7a1fdd7	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