From: Nick Ing-Simmons <nik@tiuk.ti.com>
Date: Tue, 27 Mar 2001 20:50:13 +0000 (+0000)
Subject: PerlIO::Via layer (alpha-ish).
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e7a1fdd7863072044ba7ced152ae990afb435b16;p=p5sagit%2Fp5-mst-13.2.git

PerlIO::Via layer (alpha-ish).

p4raw-id: //depot/perlio@9394
---

diff --git a/MANIFEST b/MANIFEST
index 1670956..f3685af 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -408,6 +408,9 @@ ext/POSIX/typemap		POSIX extension interface types
 ext/PerlIO/Scalar/Makefile.PL	PerlIO layer for scalars
 ext/PerlIO/Scalar/Scalar.pm	PerlIO layer for scalars
 ext/PerlIO/Scalar/Scalar.xs	PerlIO layer for scalars
+ext/PerlIO/Via/Makefile.PL	PerlIO layer for layers in perl
+ext/PerlIO/Via/Via.pm		PerlIO layer for layers in perl
+ext/PerlIO/Via/Via.xs		PerlIO layer for layers in perl
 ext/SDBM_File/Makefile.PL	SDBM extension makefile writer
 ext/SDBM_File/SDBM_File.pm	SDBM extension Perl module
 ext/SDBM_File/SDBM_File.xs	SDBM extension external subroutines
diff --git a/ext/PerlIO/Via/Makefile.PL b/ext/PerlIO/Via/Makefile.PL
new file mode 100644
index 0000000..568008e
--- /dev/null
+++ b/ext/PerlIO/Via/Makefile.PL
@@ -0,0 +1,6 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+	NAME		=> "PerlIO::Via",
+	VERSION_FROM	=> 'Via.pm',
+);
+
diff --git a/ext/PerlIO/Via/Via.pm b/ext/PerlIO/Via/Via.pm
new file mode 100644
index 0000000..f6a7a8f
--- /dev/null
+++ b/ext/PerlIO/Via/Via.pm
@@ -0,0 +1,121 @@
+package PerlIO::Via;
+our $VERSION = '0.01';
+use XSLoader ();
+XSLoader::load 'PerlIO::Via';
+1;
+__END__
+
+=head1 NAME
+
+PerlIO::Via - Helper class for PerlIO layers implemented in perl
+
+=head1 SYNOPSIS
+
+   use Some::Package;
+
+   open($fh,"<:Via(Some::Package)",...);
+
+=head1 DESCRIPTION
+
+The package to be used as a layer should implement at least some of the
+following methods. 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. (Compare TIEHANDLE.)
+Mandatory.
+
+=item $obj->POPPED([$fh])
+
+Optional - layer is about to be removed.
+
+=item $class->OPEN($path,$mode[,$fh])
+
+Not yet in use.
+
+=item $class->FDOPEN($fd)
+
+Not yet in use.
+
+=item $class->SYSOPEN($path,$imode,$perm,$fh)
+
+Not yet in use.
+
+=item $obj->FILENO($fh)
+
+Returns a numeric value for Unix-like file descriptor. Return -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 that $len).
+Optional - default is to use FILL instead.
+
+=item $obj->WRITE($buffer,$fh)
+
+Returns the number of octets from buffer that have been sucessfully 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.
+
+=item $obj->TELL($fh)
+
+Returns file postion.
+Optional. Default to be determined.
+
+=item $obj->UNREAD($buffer,$fh)
+
+Returns the number of octets from buffer that have been sucessfully 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 function of return value of FILL
+or READ.
+
+=back
+
+=cut
+
+
diff --git a/ext/PerlIO/Via/Via.xs b/ext/PerlIO/Via/Via.xs
new file mode 100644
index 0000000..3f491da
--- /dev/null
+++ b/ext/PerlIO/Via/Via.xs
@@ -0,0 +1,528 @@
+#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 *ERROR;
+ 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;
+   int i = 0;
+   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 = 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);
+         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);
+       code = -1;
+      }
+    }
+  }
+ return code;
+}
+
+PerlIO *
+PerlIOVia_open(pTHX_ PerlIO_funcs *self, AV *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)
+  {
+   dTHX;
+   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)
+    {
+     dTHX;
+     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);
+}
+
+IV
+PerlIOVia_error(PerlIO *f)
+{
+ dTHX;
+ PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
+ SV *result = PerlIOVia_method(aTHX_ f,MYMethod(ERROR),G_SCALAR,Nullsv);
+ return (result) ? SvIV(result) : PerlIOBase_error(f);
+}
+
+SV *
+PerlIOVia_getarg(PerlIO *f)
+{
+ dTHX;
+ PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
+ return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
+}
+
+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
+}
+