[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;
 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;
 CV *BINMODE;
} 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;
  }
}

/*
 * Try and call method, possibly via cached lookup.
 * If method does not exist return Nullsv (caller may fallback to another approach
 * If method does exist call it with flags passing variable number of args
 * Last arg is a "filehandle" to layer below (if present)
 * Returns scalar returned by method (if any) otherwise sv_undef
 */

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;
   PUSHSTACKi(PERLSI_MAGIC);
   ENTER;
   SPAGAIN;
   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);
    }
   else
    {
     PerlIO_debug("No next\n");
    }
   PUTBACK;
   count = call_sv((SV *)cv,flags);
   if (count)
    {
     SPAGAIN;
     result = POPs;
     PUTBACK;
    }
   else
    {
     result = &PL_sv_undef;
    }
   LEAVE;
   POPSTACK;
  }
 va_end(ap);
 return result;
}

IV
PerlIOVia_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
{
 IV code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv);
 if (code == 0)
  {
   PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
   if (!arg)
    {
     if (ckWARN(WARN_LAYER))
      Perl_warner(aTHX_ packWARN(WARN_LAYER), "No package specified");
     errno = EINVAL;
     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
      {
       if (ckWARN(WARN_LAYER))
         Perl_warner(aTHX_ packWARN(WARN_LAYER), "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
  {
   /* Reopen */
   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
    {
	/* Required open method not present */
	PerlIO_funcs *tab = NULL;
	IV m = n-1;
	while (m >= 0) {
	    PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layers, m, NULL);
	    if (t && t->Open) {
		tab = t;
		break;
	    }
	    n--;
	}
	if (tab) {
	    if ((*tab->Open) (aTHX_ tab, layers, m, mode, fd, imode, perm,
			      PerlIONext(f), narg, args)) {
		PerlIO_debug("Opened with %s => %p->%p\n",tab->name,PerlIONext(f),*PerlIONext(f));
		if (m + 1 < n) {
		    /*
		     * More layers above the one that we used to open -
		     * apply them now
		     */
		    if (PerlIO_apply_layera(aTHX_ PerlIONext(f), mode, layers, m+1, n) != 0) {
			/* If pushing layers fails close the file */
			PerlIO_close(f);
			f = NULL;
		    }
		}
		return f;
	    }
	    else {
		/* Sub-layer open failed */
	    }
	}
	else {
	    /* Nothing to do the open */
	}
     return NULL;
    }
  }
 return f;
}

IV
PerlIOVia_popped(pTHX_ PerlIO *f)
{
 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(pTHX_ PerlIO *f)
{
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 IV code = PerlIOBase_close(aTHX_ 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(pTHX_ PerlIO *f)
{
 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_binmode(pTHX_ PerlIO *f)
{
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(BINMODE),G_SCALAR,Nullsv);
 if (!result || !SvOK(result))
  {
   PerlIO_pop(aTHX_ f);
   return 0;
  }
 return SvIV(result);
}

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

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

SSize_t
PerlIOVia_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
 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(aTHX_ f,vbuf,count);
  }
}

SSize_t
PerlIOVia_read(pTHX_ 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(aTHX_ f,vbuf,count);
    }
   else
    {
     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(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
  {
   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(pTHX_ PerlIO *f)
{
 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
  {
   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(pTHX_ PerlIO *f)
{
 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(pTHX_ 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(pTHX_ 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(pTHX_ 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(pTHX_ 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(pTHX_ PerlIO *f, STDCHAR *ptr, SSize_t cnt)
{
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 s->cnt = cnt;
}

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

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

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

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

SV *
PerlIOVia_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
 return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
}

PerlIO *
PerlIOVia_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
{
 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)))
  {
   /* Most of the fields will lazily set themselves up as needed
      stash and obj have been set up by the implied push
    */
  }
 return f;
}

PerlIO_funcs PerlIO_object = {
 "Via",
 sizeof(PerlIOVia),
 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
 PerlIOVia_pushed,
 PerlIOVia_popped,
 PerlIOVia_open, /* NULL, */
 PerlIOVia_binmode, /* NULL, */
 PerlIOVia_getarg,
 PerlIOVia_fileno,
 PerlIOVia_dup,
 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;
e7a1fdd7	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;
c7997937	35	CV *mERROR;
e7a1fdd7	36	CV *mEOF;
86e05cf2	37	CV *BINMODE;
e7a1fdd7	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	}
e7a1fdd7	57	}
e7a1fdd7	58
d9dac8cd	59	/*
	60	* Try and call method, possibly via cached lookup.
	61	* If method does not exist return Nullsv (caller may fallback to another approach
	62	* If method does exist call it with flags passing variable number of args
	63	* Last arg is a "filehandle" to layer below (if present)
	64	* Returns scalar returned by method (if any) otherwise sv_undef
	65	*/
	66
e7a1fdd7	67	SV *
	68	PerlIOVia_method(pTHX_ PerlIO f,char method,CV **save,int flags,...)
	69	{
	70	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	71	CV cv = (save) ? *save : PerlIOVia_fetchmethod(aTHX_ s,method,save);
	72	SV *result = Nullsv;
	73	va_list ap;
	74	va_start(ap,flags);
	75	if (cv != (CV *)-1)
	76	{
	77	IV count;
	78	dSP;
	79	SV *arg;
24f59afc	80	PUSHSTACKi(PERLSI_MAGIC);
e7a1fdd7	81	ENTER;
24f59afc	82	SPAGAIN;
e7a1fdd7	83	PUSHMARK(sp);
	84	XPUSHs(s->obj);
	85	while ((arg = va_arg(ap,SV *)))
	86	{
	87	XPUSHs(arg);
	88	}
	89	if (*PerlIONext(f))
	90	{
	91	if (!s->fh)
	92	{
	93	GV *gv = newGVgen(HvNAME(s->stash));
	94	GvIOp(gv) = newIO();
	95	s->fh = newRV_noinc((SV *)gv);
	96	s->io = GvIOp(gv);
	97	}
	98	IoIFP(s->io) = PerlIONext(f);
	99	IoOFP(s->io) = PerlIONext(f);
	100	XPUSHs(s->fh);
	101	}
d9dac8cd	102	else
	103	{
	104	PerlIO_debug("No next\n");
	105	}
e7a1fdd7	106	PUTBACK;
	107	count = call_sv((SV *)cv,flags);
	108	if (count)
	109	{
	110	SPAGAIN;
	111	result = POPs;
	112	PUTBACK;
	113	}
	114	else
	115	{
	116	result = &PL_sv_undef;
	117	}
	118	LEAVE;
24f59afc	119	POPSTACK;
e7a1fdd7	120	}
	121	va_end(ap);
	122	return result;
	123	}
	124
	125	IV
f62ce20a	126	PerlIOVia_pushed(pTHX_ PerlIO f, const char mode, SV *arg)
e7a1fdd7	127	{
f62ce20a	128	IV code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv);
e7a1fdd7	129	if (code == 0)
e7a1fdd7	130	{
e7a1fdd7	131	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	132	if (!arg)
	133	{
99ef548b	134	if (ckWARN(WARN_LAYER))
99ef548b	135	Perl_warner(aTHX_ packWARN(WARN_LAYER), "No package specified");
d9dac8cd	136	errno = EINVAL;
e7a1fdd7	137	code = -1;
	138	}
	139	else
	140	{
	141	STRLEN pkglen = 0;
	142	char *pkg = SvPV(arg,pkglen);
267cbce7	143	s->obj = SvREFCNT_inc(arg);
e7a1fdd7	144	s->stash = gv_stashpvn(pkg, pkglen, FALSE);
	145	if (s->stash)
	146	{
	147	SV *modesv = (mode) ? sv_2mortal(newSVpvn(mode,strlen(mode))) : Nullsv;
	148	SV *result = PerlIOVia_method(aTHX_ f,MYMethod(PUSHED),G_SCALAR,modesv,Nullsv);
	149	if (result)
	150	{
	151	if (sv_isobject(result))
267cbce7	152	{
	153	s->obj = SvREFCNT_inc(result);
	154	SvREFCNT_dec(arg);
	155	}
e7a1fdd7	156	else if (SvIV(result) != 0)
	157	return SvIV(result);
	158	}
	159	if (PerlIOVia_fetchmethod(aTHX_ s,MYMethod(FILL)) == (CV *) -1)
	160	PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
	161	else
	162	PerlIOBase(f)->flags \|= PERLIO_F_FASTGETS;
	163	}
	164	else
	165	{
99ef548b	166	if (ckWARN(WARN_LAYER))
99ef548b	167	Perl_warner(aTHX_ packWARN(WARN_LAYER), "Cannot find package '%.*s'",(int) pkglen,pkg);
267cbce7	168	#ifdef ENOSYS
	169	errno = ENOSYS;
	170	#else
	171	#ifdef ENOENT
	172	errno = ENOENT;
	173	#endif
	174	#endif
e7a1fdd7	175	code = -1;
	176	}
	177	}
	178	}
	179	return code;
	180	}
	181
	182	PerlIO *
d9dac8cd	183	PerlIOVia_open(pTHX_ PerlIO_funcs self, PerlIO_list_t layers, IV n,
	184	const char *mode, int fd, int imode, int perm,
	185	PerlIO f, int narg, SV *args)
e7a1fdd7	186	{
	187	if (!f)
	188	{
	189	f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX),self,mode,PerlIOArg);
	190	}
	191	else
	192	{
d9dac8cd	193	/* Reopen */
e7a1fdd7	194	if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
	195	return NULL;
	196	}
	197	if (f)
	198	{
	199	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	200	SV *result = Nullsv;
	201	if (fd >= 0)
	202	{
	203	SV *fdsv = sv_2mortal(newSViv(fd));
	204	result = PerlIOVia_method(aTHX_ f,MYMethod(FDOPEN),G_SCALAR,fdsv,Nullsv);
	205	}
	206	else if (narg > 0)
	207	{
	208	if (*mode == '#')
	209	{
	210	SV *imodesv = sv_2mortal(newSViv(imode));
	211	SV *permsv = sv_2mortal(newSViv(perm));
	212	result = PerlIOVia_method(aTHX_ f,MYMethod(SYSOPEN),G_SCALAR,*args,imodesv,permsv,Nullsv);
	213	}
	214	else
	215	{
	216	result = PerlIOVia_method(aTHX_ f,MYMethod(OPEN),G_SCALAR,*args,Nullsv);
	217	}
	218	}
	219	if (result)
	220	{
	221	if (sv_isobject(result))
	222	s->obj = SvREFCNT_inc(result);
	223	else if (!SvTRUE(result))
	224	{
	225	return NULL;
	226	}
	227	}
	228	else
d9dac8cd	229	{
	230	/* Required open method not present */
	231	PerlIO_funcs *tab = NULL;
	232	IV m = n-1;
	233	while (m >= 0) {
	234	PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layers, m, NULL);
	235	if (t && t->Open) {
	236	tab = t;
	237	break;
	238	}
	239	n--;
	240	}
	241	if (tab) {
	242	if ((*tab->Open) (aTHX_ tab, layers, m, mode, fd, imode, perm,
	243	PerlIONext(f), narg, args)) {
	244	PerlIO_debug("Opened with %s => %p->%p\n",tab->name,PerlIONext(f),*PerlIONext(f));
	245	if (m + 1 < n) {
	246	/*
	247	* More layers above the one that we used to open -
	248	* apply them now
	249	*/
	250	if (PerlIO_apply_layera(aTHX_ PerlIONext(f), mode, layers, m+1, n) != 0) {
	251	/* If pushing layers fails close the file */
	252	PerlIO_close(f);
	253	f = NULL;
	254	}
	255	}
	256	return f;
	257	}
	258	else {
	259	/* Sub-layer open failed */
	260	}
	261	}
	262	else {
	263	/* Nothing to do the open */
	264	}
	265	return NULL;
	266	}
e7a1fdd7	267	}
	268	return f;
	269	}
	270
	271	IV
f62ce20a	272	PerlIOVia_popped(pTHX_ PerlIO *f)
e7a1fdd7	273	{
e7a1fdd7	274	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	275	PerlIOVia_method(aTHX_ f,MYMethod(POPPED),G_VOID,Nullsv);
	276	if (s->var)
	277	{
	278	SvREFCNT_dec(s->var);
	279	s->var = Nullsv;
	280	}
	281
	282	if (s->io)
	283	{
	284	IoIFP(s->io) = NULL;
	285	IoOFP(s->io) = NULL;
	286	}
	287	if (s->fh)
	288	{
	289	SvREFCNT_dec(s->fh);
	290	s->fh = Nullsv;
	291	s->io = NULL;
	292	}
	293	if (s->obj)
	294	{
	295	SvREFCNT_dec(s->obj);
	296	s->obj = Nullsv;
	297	}
	298	return 0;
	299	}
	300
	301	IV
f62ce20a	302	PerlIOVia_close(pTHX_ PerlIO *f)
e7a1fdd7	303	{
e7a1fdd7	304	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
f62ce20a	305	IV code = PerlIOBase_close(aTHX_ f);
e7a1fdd7	306	SV *result = PerlIOVia_method(aTHX_ f,MYMethod(CLOSE),G_SCALAR,Nullsv);
	307	if (result && SvIV(result) != 0)
	308	code = SvIV(result);
	309	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF\|PERLIO_F_WRBUF);
	310	return code;
	311	}
	312
	313	IV
f62ce20a	314	PerlIOVia_fileno(pTHX_ PerlIO *f)
e7a1fdd7	315	{
e7a1fdd7	316	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	317	SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILENO),G_SCALAR,Nullsv);
	318	return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
	319	}
	320
	321	IV
86e05cf2	322	PerlIOVia_binmode(pTHX_ PerlIO *f)
	323	{
	324	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	325	SV *result = PerlIOVia_method(aTHX_ f,MYMethod(BINMODE),G_SCALAR,Nullsv);
	326	if (!result \|\| !SvOK(result))
	327	{
	328	PerlIO_pop(aTHX_ f);
	329	return 0;
	330	}
	331	return SvIV(result);
	332	}
	333
	334	IV
f62ce20a	335	PerlIOVia_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
e7a1fdd7	336	{
e7a1fdd7	337	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
e7a1fdd7	338	SV *offsv = sv_2mortal(newSViv(offset));
9f16d962	339	SV *whsv = sv_2mortal(newSViv(whence));
e7a1fdd7	340	SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
	341	return (result) ? SvIV(result) : -1;
	342	}
	343
	344	Off_t
f62ce20a	345	PerlIOVia_tell(pTHX_ PerlIO *f)
e7a1fdd7	346	{
e7a1fdd7	347	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
e7a1fdd7	348	SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
9f16d962	349	return (result) ? (Off_t) SvIV(result) : (Off_t) -1;
e7a1fdd7	350	}
	351
	352	SSize_t
f62ce20a	353	PerlIOVia_unread(pTHX_ PerlIO f, const void vbuf, Size_t count)
e7a1fdd7	354	{
e7a1fdd7	355	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	356	SV buf = sv_2mortal(newSVpvn((char )vbuf,count));
	357	SV *result = PerlIOVia_method(aTHX_ f,MYMethod(UNREAD),G_SCALAR,buf,Nullsv);
	358	if (result)
	359	return (SSize_t) SvIV(result);
	360	else
	361	{
f62ce20a	362	return PerlIOBase_unread(aTHX_ f,vbuf,count);
e7a1fdd7	363	}
	364	}
	365
	366	SSize_t
f62ce20a	367	PerlIOVia_read(pTHX_ PerlIO f, void vbuf, Size_t count)
e7a1fdd7	368	{
	369	SSize_t rd = 0;
	370	if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
	371	{
	372	if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)
	373	{
f62ce20a	374	rd = PerlIOBase_read(aTHX_ f,vbuf,count);
e7a1fdd7	375	}
	376	else
	377	{
e7a1fdd7	378	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	379	SV *buf = sv_2mortal(newSV(count));
	380	SV *n = sv_2mortal(newSViv(count));
	381	SV *result = PerlIOVia_method(aTHX_ f,MYMethod(READ),G_SCALAR,buf,n,Nullsv);
	382	if (result)
	383	{
	384	rd = (SSize_t) SvIV(result);
	385	Move(SvPVX(buf),vbuf,rd,char);
	386	return rd;
	387	}
	388	}
	389	}
	390	return rd;
	391	}
	392
	393	SSize_t
f62ce20a	394	PerlIOVia_write(pTHX_ PerlIO f, const void vbuf, Size_t count)
e7a1fdd7	395	{
	396	if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
	397	{
e7a1fdd7	398	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	399	SV buf = newSVpvn((char )vbuf,count);
	400	SV *result = PerlIOVia_method(aTHX_ f,MYMethod(WRITE),G_SCALAR,buf,Nullsv);
	401	SvREFCNT_dec(buf);
	402	if (result)
	403	return (SSize_t) SvIV(result);
	404	return -1;
	405	}
	406	return 0;
	407	}
	408
	409	IV
f62ce20a	410	PerlIOVia_fill(pTHX_ PerlIO *f)
e7a1fdd7	411	{
	412	if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
	413	{
e7a1fdd7	414	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	415	SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILL),G_SCALAR,Nullsv);
	416	if (s->var)
	417	{
	418	SvREFCNT_dec(s->var);
	419	s->var = Nullsv;
	420	}
	421	if (result && SvOK(result))
	422	{
	423	STRLEN len = 0;
	424	char *p = SvPV(result,len);
	425	s->var = newSVpvn(p,len);
	426	s->cnt = SvCUR(s->var);
	427	return 0;
	428	}
	429	else
	430	PerlIOBase(f)->flags \|= PERLIO_F_EOF;
	431	}
	432	return -1;
	433	}
	434
	435	IV
f62ce20a	436	PerlIOVia_flush(pTHX_ PerlIO *f)
e7a1fdd7	437	{
e7a1fdd7	438	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	439	SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FLUSH),G_SCALAR,Nullsv);
	440	if (s->var && s->cnt > 0)
	441	{
	442	SvREFCNT_dec(s->var);
	443	s->var = Nullsv;
	444	}
	445	return (result) ? SvIV(result) : 0;
	446	}
	447
	448	STDCHAR *
f62ce20a	449	PerlIOVia_get_base(pTHX_ PerlIO *f)
e7a1fdd7	450	{
	451	if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
	452	{
e7a1fdd7	453	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	454	if (s->var)
	455	{
	456	return (STDCHAR *)SvPVX(s->var);
	457	}
	458	}
	459	return (STDCHAR *) Nullch;
	460	}
	461
	462	STDCHAR *
f62ce20a	463	PerlIOVia_get_ptr(pTHX_ PerlIO *f)
e7a1fdd7	464	{
	465	if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
	466	{
	467	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	468	if (s->var)
	469	{
e7a1fdd7	470	STDCHAR p = (STDCHAR )(SvEND(s->var) - s->cnt);
	471	return p;
	472	}
	473	}
	474	return (STDCHAR *) Nullch;
	475	}
	476
	477	SSize_t
f62ce20a	478	PerlIOVia_get_cnt(pTHX_ PerlIO *f)
e7a1fdd7	479	{
	480	if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
	481	{
	482	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	483	if (s->var)
	484	{
	485	return s->cnt;
	486	}
	487	}
	488	return 0;
	489	}
	490
	491	Size_t
f62ce20a	492	PerlIOVia_bufsiz(pTHX_ PerlIO *f)
e7a1fdd7	493	{
	494	if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
	495	{
	496	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	497	if (s->var)
	498	return SvCUR(s->var);
	499	}
	500	return 0;
	501	}
	502
	503	void
f62ce20a	504	PerlIOVia_set_ptrcnt(pTHX_ PerlIO f, STDCHAR ptr, SSize_t cnt)
e7a1fdd7	505	{
	506	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	507	s->cnt = cnt;
	508	}
	509
	510	void
f62ce20a	511	PerlIOVia_setlinebuf(pTHX_ PerlIO *f)
e7a1fdd7	512	{
e7a1fdd7	513	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
e7a1fdd7	514	PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
f62ce20a	515	PerlIOBase_setlinebuf(aTHX_ f);
e7a1fdd7	516	}
	517
	518	void
f62ce20a	519	PerlIOVia_clearerr(pTHX_ PerlIO *f)
e7a1fdd7	520	{
e7a1fdd7	521	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
e7a1fdd7	522	PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
f62ce20a	523	PerlIOBase_clearerr(aTHX_ f);
e7a1fdd7	524	}
e7a1fdd7	525
c7997937	526	IV
f62ce20a	527	PerlIOVia_error(pTHX_ PerlIO *f)
e7a1fdd7	528	{
e7a1fdd7	529	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
c7997937	530	SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
f62ce20a	531	return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
e7a1fdd7	532	}
	533
	534	IV
f62ce20a	535	PerlIOVia_eof(pTHX_ PerlIO *f)
e7a1fdd7	536	{
e7a1fdd7	537	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
e7a1fdd7	538	SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
f62ce20a	539	return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
e7a1fdd7	540	}
e7a1fdd7	541
ecdeb87c	542	SV *
	543	PerlIOVia_getarg(pTHX_ PerlIO f, CLONE_PARAMS param, int flags)
	544	{
	545	PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
	546	return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
	547	}
	548
8cf8f3d1	549	PerlIO *
ecdeb87c	550	PerlIOVia_dup(pTHX_ PerlIO f, PerlIO o, CLONE_PARAMS *param, int flags)
8cf8f3d1	551	{
ecdeb87c	552	if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)))
9f16d962	553	{
ecdeb87c	554	/* Most of the fields will lazily set themselves up as needed
9f16d962	555	stash and obj have been set up by the implied push
	556	*/
	557	}
	558	return f;
8cf8f3d1	559	}
8cf8f3d1	560
e7a1fdd7	561	PerlIO_funcs PerlIO_object = {
	562	"Via",
	563	sizeof(PerlIOVia),
	564	PERLIO_K_BUFFERED\|PERLIO_K_DESTRUCT,
	565	PerlIOVia_pushed,
	566	PerlIOVia_popped,
d9dac8cd	567	PerlIOVia_open, /* NULL, */
86e05cf2	568	PerlIOVia_binmode, /* NULL, */
e7a1fdd7	569	PerlIOVia_getarg,
e7a1fdd7	570	PerlIOVia_fileno,
8cf8f3d1	571	PerlIOVia_dup,
e7a1fdd7	572	PerlIOVia_read,
	573	PerlIOVia_unread,
	574	PerlIOVia_write,
	575	PerlIOVia_seek,
	576	PerlIOVia_tell,
	577	PerlIOVia_close,
	578	PerlIOVia_flush,
	579	PerlIOVia_fill,
	580	PerlIOVia_eof,
	581	PerlIOVia_error,
	582	PerlIOVia_clearerr,
	583	PerlIOVia_setlinebuf,
	584	PerlIOVia_get_base,
	585	PerlIOVia_bufsiz,
	586	PerlIOVia_get_ptr,
	587	PerlIOVia_get_cnt,
	588	PerlIOVia_set_ptrcnt,
	589	};
	590
	591
	592	#endif /* Layers available */
	593
	594	MODULE = PerlIO::Via PACKAGE = PerlIO::Via
	595	PROTOTYPES: ENABLE;
	596
	597	BOOT:
	598	{
	599	#ifdef PERLIO_LAYERS
	600	PerlIO_define_layer(aTHX_ &PerlIO_object);
	601	#endif
	602	}
	603