Rename ext/PerlIO/via to ext/PerlIO-via

5 files changed, 988 insertions, 0 deletions

diff --git a/ext/PerlIO-via/Makefile.PL b/ext/PerlIO-via/Makefile.PL
new file mode 100644
index 0000000000..deb401f5e2
--- /dev/null
+++ b/ext/PerlIO-via/Makefile.PL
@@ -0,0 +1,7 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+	NAME		=> "PerlIO::via",
+	MAN3PODS    => {},  # Pods will be built by installman.
+	VERSION_FROM	=> 'via.pm',
+);
+
diff --git a/ext/PerlIO-via/hints/aix.pl b/ext/PerlIO-via/hints/aix.pl
new file mode 100644
index 0000000000..960a8fdfe0
--- /dev/null
+++ b/ext/PerlIO-via/hints/aix.pl
@@ -0,0 +1,2 @@
+# compilation may hang at -O3 level
+$self->{OPTIMIZE} = '-O';
diff --git a/ext/PerlIO-via/t/via.t b/ext/PerlIO-via/t/via.t
new file mode 100644
index 0000000000..7d46f40dc8
--- /dev/null
+++ b/ext/PerlIO-via/t/via.t
@@ -0,0 +1,92 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    unless (find PerlIO::Layer 'perlio') {
+	print "1..0 # Skip: not perlio\n";
+	exit 0;
+    }
+    require Config;
+    if (($Config::Config{'extensions'} !~ m!\bPerlIO/via\b!) ){
+        print "1..0 # Skip -- Perl configured without PerlIO::via module\n";
+        exit 0;
+    }
+}
+
+use strict;
+use warnings;
+
+my $tmp = "via$$";
+
+use Test::More tests => 18;
+
+my $fh;
+my $a = join("", map { chr } 0..255) x 10;
+my $b;
+
+BEGIN { use_ok('PerlIO::via::QuotedPrint'); }
+
+ok( !open($fh,"<via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for input fails');
+ok(  open($fh,">via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for output');
+ok( (print $fh $a), "print to output file");
+ok( close($fh), 'close output file');
+
+ok( open($fh,"<via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for input');
+{ local $/; $b = <$fh> }
+ok( close($fh), "close input file");
+
+is($a, $b, 'compare original data with filtered version');
+
+
+{
+    my $warnings = '';
+    local $SIG{__WARN__} = sub { $warnings = join '', @_ };
+
+    use warnings 'layer';
+
+    # Find fd number we should be using
+    my $fd = open($fh,">$tmp") && fileno($fh);
+    print $fh "Hello\n";
+    close($fh);
+
+    ok( ! open($fh,">via(Unknown::Module)", $tmp), 'open via Unknown::Module will fail');
+    like( $warnings, qr/^Cannot find package 'Unknown::Module'/,  'warn about unknown package' );
+
+    # Now open normally again to see if we get right fileno
+    my $fd2 = open($fh,"<$tmp") && fileno($fh);
+    is($fd2,$fd,"Wrong fd number after failed open");
+
+    my $data = <$fh>;
+
+    is($data,"Hello\n","File clobbered by failed open");
+
+    close($fh);
+
+{
+package Incomplete::Module; 
+}
+
+    $warnings = '';
+    no warnings 'layer';
+    ok( ! open($fh,">via(Incomplete::Module)", $tmp), 'open via Incomplete::Module will fail');
+    is( $warnings, "",  "don't warn about unknown package" );
+
+    $warnings = '';
+    no warnings 'layer';
+    ok( ! open($fh,">via(Unknown::Module)", $tmp), 'open via Unknown::Module will fail');
+    is( $warnings, "",  "don't warn about unknown package" );
+}
+
+my $obj = '';
+sub Foo::PUSHED			{ $obj = shift; -1; }
+sub PerlIO::via::Bar::PUSHED	{ $obj = shift; -1; }
+open $fh, '<:via(Foo)', "foo";
+is( $obj, 'Foo', 'search for package Foo' );
+open $fh, '<:via(Bar)', "bar";
+is( $obj, 'PerlIO::via::Bar', 'search for package PerlIO::via::Bar' );
+
+END {
+    1 while unlink $tmp;
+}
+
diff --git a/ext/PerlIO-via/via.pm b/ext/PerlIO-via/via.pm
new file mode 100644
index 0000000000..53d435853a
--- /dev/null
+++ b/ext/PerlIO-via/via.pm
@@ -0,0 +1,243 @@
+package PerlIO::via;
+our $VERSION = '0.08';
+use XSLoader ();
+XSLoader::load 'PerlIO::via';
+1;
+__END__
+
+=head1 NAME
+
+PerlIO::via - Helper class for PerlIO layers implemented in perl
+
+=head1 SYNOPSIS
+
+   use PerlIO::via::Layer;
+   open($fh,"<:via(Layer)",...);
+
+   use Some::Other::Package;
+   open($fh,">:via(Some::Other::Package)",...);
+
+=head1 DESCRIPTION
+
+The PerlIO::via module allows you to develop PerlIO layers in Perl, without
+having to go into the nitty gritty of programming C with XS as the interface
+to Perl.
+
+One example module, L<PerlIO::via::QuotedPrint>, is included with Perl
+5.8.0, and more example modules are available from CPAN, such as
+L<PerlIO::via::StripHTML> and L<PerlIO::via::Base64>.  The
+PerlIO::via::StripHTML module for instance, allows you to say:
+
+	use PerlIO::via::StripHTML;
+	open( my $fh, "<:via(StripHTML)", "index.html" );
+        my @line = <$fh>;
+
+to obtain the text of an HTML-file in an array with all the HTML-tags
+automagically removed.
+
+Please note that if the layer is created in the PerlIO::via:: namespace, it
+does B<not> have to be fully qualified.  The PerlIO::via module will prefix
+the PerlIO::via:: namespace if the specified modulename does not exist as a
+fully qualified module name.
+
+=head1 EXPECTED METHODS
+
+To create a Perl module that implements a PerlIO layer in Perl (as opposed to
+in C using XS as the interface to Perl), you need to supply some of the
+following subroutines.  It is recommended to create these Perl modules in the
+PerlIO::via:: namespace, so that they can easily be located on CPAN and use
+the default namespace feature of the PerlIO::via module itself.
+
+Please note that this is an area of recent development in Perl and that the
+interface described here is therefore still subject to change (and hopefully
+will have better documentation and more examples).
+
+In the method descriptions below I<$fh> will be
+a reference to a glob which can be treated as a perl file handle.
+It refers to the layer below. I<$fh> is not passed if the layer
+is at the bottom of the stack, for this reason and to maintain
+some level of "compatibility" with TIEHANDLE classes it is passed last.
+
+=over 4
+
+=item $class->PUSHED([$mode,[$fh]])
+
+Should return an object or the class, or -1 on failure.  (Compare
+TIEHANDLE.)  The arguments are an optional mode string ("r", "w",
+"w+", ...) and a filehandle for the PerlIO layer below.  Mandatory.
+
+When the layer is pushed as part of an C<open> call, C<PUSHED> will be called
+I<before> the actual open occurs, whether that be via C<OPEN>, C<SYSOPEN>,
+C<FDOPEN> or by letting a lower layer do the open.
+
+=item $obj->POPPED([$fh])
+
+Optional - called when the layer is about to be removed.
+
+=item $obj->UTF8($bellowFlag,[$fh])
+
+Optional - if present it will be called immediately after PUSHED has
+returned. It should return a true value if the layer expects data to be
+UTF-8 encoded. If it returns true, the result is as if the caller had done
+
+   ":via(YourClass):utf8"
+
+If not present or if it returns false, then the stream is left with
+the UTF-8 flag clear.
+The I<$bellowFlag> argument will be true if there is a layer below
+and that layer was expecting UTF-8.
+
+=item $obj->OPEN($path,$mode,[$fh])
+
+Optional - if not present a lower layer does the open.
+If present, called for normal opens after the layer is pushed.
+This function is subject to change as there is no easy way
+to get a lower layer to do the open and then regain control.
+
+=item $obj->BINMODE([$fh])
+
+Optional - if not present the layer is popped on binmode($fh) or when C<:raw>
+is pushed. If present it should return 0 on success, -1 on error, or undef
+to pop the layer.
+
+=item $obj->FDOPEN($fd,[$fh])
+
+Optional - if not present a lower layer does the open.
+If present, called after the layer is pushed for opens which pass
+a numeric file descriptor.
+This function is subject to change as there is no easy way
+to get a lower layer to do the open and then regain control.
+
+=item $obj->SYSOPEN($path,$imode,$perm,[$fh])
+
+Optional - if not present a lower layer does the open.
+If present, called after the layer is pushed for sysopen style opens
+which pass a numeric mode and permissions.
+This function is subject to change as there is no easy way
+to get a lower layer to do the open and then regain control.
+
+=item $obj->FILENO($fh)
+
+Returns a numeric value for a Unix-like file descriptor. Returns -1 if
+there isn't one.  Optional.  Default is fileno($fh).
+
+=item $obj->READ($buffer,$len,$fh)
+
+Returns the number of octets placed in $buffer (must be less than or
+equal to $len).  Optional.  Default is to use FILL instead.
+
+=item $obj->WRITE($buffer,$fh)
+
+Returns the number of octets from $buffer that have been successfully written.
+
+=item $obj->FILL($fh)
+
+Should return a string to be placed in the buffer.  Optional. If not
+provided, must provide READ or reject handles open for reading in
+PUSHED.
+
+=item $obj->CLOSE($fh)
+
+Should return 0 on success, -1 on error.
+Optional.
+
+=item $obj->SEEK($posn,$whence,$fh)
+
+Should return 0 on success, -1 on error.
+Optional.  Default is to fail, but that is likely to be changed
+in future.
+
+=item $obj->TELL($fh)
+
+Returns file position.
+Optional.  Default to be determined.
+
+=item $obj->UNREAD($buffer,$fh)
+
+Returns the number of octets from $buffer that have been successfully
+saved to be returned on future FILL/READ calls.  Optional.  Default is
+to push data into a temporary layer above this one.
+
+=item $obj->FLUSH($fh)
+
+Flush any buffered write data.  May possibly be called on readable
+handles too.  Should return 0 on success, -1 on error.
+
+=item $obj->SETLINEBUF($fh)
+
+Optional. No return.
+
+=item $obj->CLEARERR($fh)
+
+Optional. No return.
+
+=item $obj->ERROR($fh)
+
+Optional. Returns error state. Default is no error until a mechanism
+to signal error (die?) is worked out.
+
+=item $obj->EOF($fh)
+
+Optional. Returns end-of-file state. Default is a function of the return
+value of FILL or READ.
+
+=back
+
+=head1 EXAMPLES
+
+Check the PerlIO::via:: namespace on CPAN for examples of PerlIO layers
+implemented in Perl.  To give you an idea how simple the implementation of
+a PerlIO layer can look, a simple example is included here.
+
+=head2 Example - a Hexadecimal Handle
+
+Given the following module, PerlIO::via::Hex :
+
+    package PerlIO::via::Hex;
+
+    sub PUSHED
+    {
+     my ($class,$mode,$fh) = @_;
+     # When writing we buffer the data
+     my $buf = '';
+     return bless \$buf,$class;
+    }
+
+    sub FILL
+    {
+     my ($obj,$fh) = @_;
+     my $line = <$fh>;
+     return (defined $line) ? pack("H*", $line) : undef;
+    }
+
+    sub WRITE
+    {
+     my ($obj,$buf,$fh) = @_;
+     $$obj .= unpack("H*", $buf);
+     return length($buf);
+    }
+
+    sub FLUSH
+    {
+     my ($obj,$fh) = @_;
+     print $fh $$obj or return -1;
+     $$obj = '';
+     return 0;
+    }
+
+    1;
+
+The following code opens up an output handle that will convert any
+output to a hexadecimal dump of the output bytes: for example "A" will
+be converted to "41" (on ASCII-based machines, on EBCDIC platforms
+the "A" will become "c1")
+
+    use PerlIO::via::Hex;
+    open(my $fh, ">:via(Hex)", "foo.hex");
+
+and the following code will read the hexdump in and convert it
+on the fly back into bytes:
+
+    open(my $fh, "<:via(Hex)", "foo.hex");
+
+=cut
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
new file mode 100644
index 0000000000..fd5234a128
--- /dev/null
+++ b/ext/PerlIO-via/via.xs
@@ -0,0 +1,644 @@
+#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;
+ CV *UTF8;
+} PerlIOVia;
+
+#define MYMethod(x) #x,&s->x
+
+CV *
+PerlIOVia_fetchmethod(pTHX_ PerlIOVia * s, const char *method, CV ** save)
+{
+    GV *gv = gv_fetchmeth(s->stash, method, strlen(method), 0);
+#if 0
+    Perl_warn(aTHX_ "Lookup %s::%s => %p", HvNAME_get(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, const 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_get(s->stash));
+		GvIOp(gv) = newIO();
+		s->fh = newRV((SV *) gv);
+		s->io = GvIOp(gv);
+		if (gv) {
+		    /* shamelessly stolen from IO::File's new_tmpfile() */
+		    hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
+		}
+	    }
+	    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;
+	    const char *pkg = SvPV(arg, pkglen);
+	    s->obj =
+		newSVpvn(Perl_form(aTHX_ "PerlIO::via::%s", pkg),
+			 pkglen + 13);
+	    s->stash = gv_stashpvn(SvPVX_const(s->obj), pkglen + 13, 0);
+	    if (!s->stash) {
+		SvREFCNT_dec(s->obj);
+		s->obj = SvREFCNT_inc(arg);
+		s->stash = gv_stashpvn(pkg, pkglen, 0);
+	    }
+	    if (s->stash) {
+		char lmode[8];
+		SV *modesv;
+		SV *result;
+		if (!mode) {
+		    /* binmode() passes NULL - so find out what mode is */
+		    mode = PerlIO_modestr(f,lmode);
+		}
+		modesv = sv_2mortal(newSVpvn(mode, strlen(mode)));
+		result = PerlIOVia_method(aTHX_ f, MYMethod(PUSHED), G_SCALAR,
+				     modesv, Nullsv);
+		if (result) {
+		    if (sv_isobject(result)) {
+			SvREFCNT_dec(s->obj);
+			s->obj = SvREFCNT_inc(result);
+		    }
+		    else if (SvIV(result) != 0)
+			return SvIV(result);
+		}
+		else {
+		    goto push_failed;
+		}
+		modesv = (*PerlIONext(f) && (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_UTF8))
+                           ? &PL_sv_yes : &PL_sv_no;
+		result = PerlIOVia_method(aTHX_ f, MYMethod(UTF8), G_SCALAR, modesv, Nullsv);
+		if (result && SvTRUE(result)) {
+		    PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+		}
+		else {
+		    PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
+		}
+		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);
+push_failed:
+#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;
+		}
+		m--;
+	    }
+	    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(sizeof(Off_t) > sizeof(IV)
+			   ? newSVnv((NV)offset) : newSViv((IV)offset));
+    SV *whsv = sv_2mortal(newSViv(whence));
+    SV *result =
+	PerlIOVia_method(aTHX_ f, MYMethod(SEEK), G_SCALAR, offsv, whsv,
+			 Nullsv);
+#if Off_t_size == 8 && defined(CONDOP_SIZE) && CONDOP_SIZE < Off_t_size
+    if (result)
+	return (Off_t) SvIV(result);
+    else
+	return (Off_t) -1;
+#else
+    return (result) ? SvIV(result) : -1;
+#endif
+}
+
+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)
+	   ? (SvNOK(result) ? (Off_t)SvNV(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;
+	    const 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 *) NULL;
+}
+
+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 *) NULL;
+}
+
+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_DECL(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_FUNCS_CAST(&PerlIO_object));
+#endif
+}
+
+
+
+
+