From e7a1fdd7863072044ba7ced152ae990afb435b16 Mon Sep 17 00:00:00 2001 From: Nick Ing-Simmons Date: Tue, 27 Mar 2001 20:50:13 +0000 Subject: [PATCH] PerlIO::Via layer (alpha-ish). p4raw-id: //depot/perlio@9394 --- MANIFEST | 3 + ext/PerlIO/Via/Makefile.PL | 6 + ext/PerlIO/Via/Via.pm | 121 +++++++++++ ext/PerlIO/Via/Via.xs | 528 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 658 insertions(+) create mode 100644 ext/PerlIO/Via/Makefile.PL create mode 100644 ext/PerlIO/Via/Via.pm create mode 100644 ext/PerlIO/Via/Via.xs 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 +} + -- 2.7.4