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