SV * obj;
SV * var;
SSize_t cnt;
- Off_t posn;
IO * io;
SV * fh;
CV *PUSHED;
{
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,...)
{
IV count;
dSP;
SV *arg;
- int i = 0;
+ PUSHSTACKi(PERLSI_MAGIC);
ENTER;
+ SPAGAIN;
PUSHMARK(sp);
XPUSHs(s->obj);
while ((arg = va_arg(ap,SV *)))
IoOFP(s->io) = PerlIONext(f);
XPUSHs(s->fh);
}
+ else
+ {
+ PerlIO_debug("No next\n");
+ }
PUTBACK;
count = call_sv((SV *)cv,flags);
if (count)
result = &PL_sv_undef;
}
LEAVE;
+ POPSTACK;
}
va_end(ap);
return result;
}
IV
-PerlIOVia_pushed(PerlIO *f, const char *mode, SV *arg)
+PerlIOVia_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
{
- IV code = PerlIOBase_pushed(f,mode,Nullsv);
+ IV code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv);
if (code == 0)
{
- dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
if (!arg)
{
- Perl_warn(aTHX_ "No package specified");
+ 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 = arg;
+ s->obj = SvREFCNT_inc(arg);
s->stash = gv_stashpvn(pkg, pkglen, FALSE);
if (s->stash)
{
if (result)
{
if (sv_isobject(result))
- s->obj = SvREFCNT_inc(result);
+ {
+ s->obj = SvREFCNT_inc(result);
+ SvREFCNT_dec(arg);
+ }
else if (SvIV(result) != 0)
return SvIV(result);
}
}
else
{
- Perl_warn(aTHX_ "Cannot find package '%.*s'",(int) pkglen,pkg);
+ 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;
}
}
}
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)
+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)
{
}
else
{
+ /* Reopen */
if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
return NULL;
}
}
}
else
- return NULL;
+ {
+ /* 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(PerlIO *f)
+PerlIOVia_popped(pTHX_ PerlIO *f)
{
- dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
PerlIOVia_method(aTHX_ f,MYMethod(POPPED),G_VOID,Nullsv);
if (s->var)
}
IV
-PerlIOVia_close(PerlIO *f)
+PerlIOVia_close(pTHX_ PerlIO *f)
{
- dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
- IV code = PerlIOBase_close(f);
+ 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);
}
IV
-PerlIOVia_fileno(PerlIO *f)
+PerlIOVia_fileno(pTHX_ 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)
+PerlIOVia_seek(pTHX_ 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 *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(PerlIO *f)
+PerlIOVia_tell(pTHX_ 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;
+ return (result) ? (Off_t) SvIV(result) : (Off_t) -1;
}
SSize_t
-PerlIOVia_unread(PerlIO *f, const void *vbuf, Size_t count)
+PerlIOVia_unread(pTHX_ 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);
return (SSize_t) SvIV(result);
else
{
- return PerlIOBase_unread(f,vbuf,count);
+ return PerlIOBase_unread(aTHX_ f,vbuf,count);
}
}
SSize_t
-PerlIOVia_read(PerlIO *f, void *vbuf, Size_t count)
+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(f,vbuf,count);
+ rd = PerlIOBase_read(aTHX_ f,vbuf,count);
}
else
{
- dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
SV *buf = sv_2mortal(newSV(count));
SV *n = sv_2mortal(newSViv(count));
}
SSize_t
-PerlIOVia_write(PerlIO *f, const void *vbuf, Size_t count)
+PerlIOVia_write(pTHX_ 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);
}
IV
-PerlIOVia_fill(PerlIO *f)
+PerlIOVia_fill(pTHX_ 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)
}
IV
-PerlIOVia_flush(PerlIO *f)
+PerlIOVia_flush(pTHX_ 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)
}
STDCHAR *
-PerlIOVia_get_base(PerlIO *f)
+PerlIOVia_get_base(pTHX_ PerlIO *f)
{
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
{
- dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
if (s->var)
{
}
STDCHAR *
-PerlIOVia_get_ptr(PerlIO *f)
+PerlIOVia_get_ptr(pTHX_ 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;
}
}
SSize_t
-PerlIOVia_get_cnt(PerlIO *f)
+PerlIOVia_get_cnt(pTHX_ PerlIO *f)
{
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
{
}
Size_t
-PerlIOVia_bufsiz(PerlIO *f)
+PerlIOVia_bufsiz(pTHX_ PerlIO *f)
{
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
{
}
void
-PerlIOVia_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
+PerlIOVia_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR *ptr, SSize_t cnt)
{
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
s->cnt = cnt;
}
void
-PerlIOVia_setlinebuf(PerlIO *f)
+PerlIOVia_setlinebuf(pTHX_ PerlIO *f)
{
- dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
- PerlIOBase_setlinebuf(f);
+ PerlIOBase_setlinebuf(aTHX_ f);
}
void
-PerlIOVia_clearerr(PerlIO *f)
+PerlIOVia_clearerr(pTHX_ PerlIO *f)
{
- dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
- PerlIOBase_clearerr(f);
+ PerlIOBase_clearerr(aTHX_ f);
}
-SV *
-PerlIOVia_getarg(PerlIO *f)
+IV
+PerlIOVia_error(pTHX_ PerlIO *f)
{
- dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
- return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
+ SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
+ return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
}
IV
-PerlIOVia_error(PerlIO *f)
+PerlIOVia_eof(pTHX_ PerlIO *f)
{
- dTHX;
PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
- SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
- return (result) ? SvIV(result) : PerlIOBase_error(f);
+ SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
+ return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
}
-IV
-PerlIOVia_eof(PerlIO *f)
+SV *
+PerlIOVia_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
- 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);
+ 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 = {
PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
PerlIOVia_pushed,
PerlIOVia_popped,
- NULL, /* PerlIOVia_open, */
+ PerlIOVia_open, /* NULL, */
PerlIOVia_getarg,
PerlIOVia_fileno,
+ PerlIOVia_dup,
PerlIOVia_read,
PerlIOVia_unread,
PerlIOVia_write,
projects / p5sagit/p5-mst-13.2.git / blobdiff