1 #define PERL_NO_GET_CONTEXT
11 struct _PerlIO base; /* Base "class" info */
40 #define MYMethod(x) #x,&s->x
43 PerlIOVia_fetchmethod(pTHX_ PerlIOVia *s,char *method,CV **save)
45 GV *gv = gv_fetchmeth(s->stash,method,strlen(method),0);
47 Perl_warn(aTHX_ "Lookup %s::%s => %p",HvNAME(s->stash),method,gv);
51 return *save = GvCV(gv);
55 return *save = (CV *) -1;
61 PerlIOVia_method(pTHX_ PerlIO *f,char *method,CV **save,int flags,...)
63 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
64 CV *cv = (*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s,method,save);
76 while ((arg = va_arg(ap,SV *)))
84 GV *gv = newGVgen(HvNAME(s->stash));
86 s->fh = newRV_noinc((SV *)gv);
89 IoIFP(s->io) = PerlIONext(f);
90 IoOFP(s->io) = PerlIONext(f);
94 count = call_sv((SV *)cv,flags);
103 result = &PL_sv_undef;
112 PerlIOVia_pushed(PerlIO *f, const char *mode, SV *arg)
114 IV code = PerlIOBase_pushed(f,mode,Nullsv);
118 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
121 Perl_warn(aTHX_ "No package specified");
127 char *pkg = SvPV(arg,pkglen);
128 s->obj = SvREFCNT_inc(arg);
129 s->stash = gv_stashpvn(pkg, pkglen, FALSE);
132 SV *modesv = (mode) ? sv_2mortal(newSVpvn(mode,strlen(mode))) : Nullsv;
133 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(PUSHED),G_SCALAR,modesv,Nullsv);
136 if (sv_isobject(result))
138 s->obj = SvREFCNT_inc(result);
141 else if (SvIV(result) != 0)
144 if (PerlIOVia_fetchmethod(aTHX_ s,MYMethod(FILL)) == (CV *) -1)
145 PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
147 PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
151 Perl_warn(aTHX_ "Cannot find package '%.*s'",(int) pkglen,pkg);
167 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)
171 f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX),self,mode,PerlIOArg);
175 if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
180 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
184 SV *fdsv = sv_2mortal(newSViv(fd));
185 result = PerlIOVia_method(aTHX_ f,MYMethod(FDOPEN),G_SCALAR,fdsv,Nullsv);
191 SV *imodesv = sv_2mortal(newSViv(imode));
192 SV *permsv = sv_2mortal(newSViv(perm));
193 result = PerlIOVia_method(aTHX_ f,MYMethod(SYSOPEN),G_SCALAR,*args,imodesv,permsv,Nullsv);
197 result = PerlIOVia_method(aTHX_ f,MYMethod(OPEN),G_SCALAR,*args,Nullsv);
202 if (sv_isobject(result))
203 s->obj = SvREFCNT_inc(result);
204 else if (!SvTRUE(result))
216 PerlIOVia_popped(PerlIO *f)
219 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
220 PerlIOVia_method(aTHX_ f,MYMethod(POPPED),G_VOID,Nullsv);
223 SvREFCNT_dec(s->var);
240 SvREFCNT_dec(s->obj);
247 PerlIOVia_close(PerlIO *f)
250 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
251 IV code = PerlIOBase_close(f);
252 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(CLOSE),G_SCALAR,Nullsv);
253 if (result && SvIV(result) != 0)
255 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
260 PerlIOVia_fileno(PerlIO *f)
263 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
264 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILENO),G_SCALAR,Nullsv);
265 return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
269 PerlIOVia_seek(PerlIO *f, Off_t offset, int whence)
272 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
273 SV *offsv = sv_2mortal(newSViv(offset));
274 SV *whsv = sv_2mortal(newSViv(offset));
275 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
276 return (result) ? SvIV(result) : -1;
280 PerlIOVia_tell(PerlIO *f)
283 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
284 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
285 return (result) ? (Off_t) SvIV(result) : s->posn;
289 PerlIOVia_unread(PerlIO *f, const void *vbuf, Size_t count)
292 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
293 SV *buf = sv_2mortal(newSVpvn((char *)vbuf,count));
294 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(UNREAD),G_SCALAR,buf,Nullsv);
296 return (SSize_t) SvIV(result);
299 return PerlIOBase_unread(f,vbuf,count);
304 PerlIOVia_read(PerlIO *f, void *vbuf, Size_t count)
307 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
309 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)
311 rd = PerlIOBase_read(f,vbuf,count);
316 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
317 SV *buf = sv_2mortal(newSV(count));
318 SV *n = sv_2mortal(newSViv(count));
319 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(READ),G_SCALAR,buf,n,Nullsv);
322 rd = (SSize_t) SvIV(result);
323 Move(SvPVX(buf),vbuf,rd,char);
332 PerlIOVia_write(PerlIO *f, const void *vbuf, Size_t count)
334 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
337 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
338 SV *buf = newSVpvn((char *)vbuf,count);
339 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(WRITE),G_SCALAR,buf,Nullsv);
342 return (SSize_t) SvIV(result);
349 PerlIOVia_fill(PerlIO *f)
351 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
354 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
355 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILL),G_SCALAR,Nullsv);
358 SvREFCNT_dec(s->var);
361 if (result && SvOK(result))
364 char *p = SvPV(result,len);
365 s->var = newSVpvn(p,len);
366 s->cnt = SvCUR(s->var);
370 PerlIOBase(f)->flags |= PERLIO_F_EOF;
376 PerlIOVia_flush(PerlIO *f)
379 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
380 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FLUSH),G_SCALAR,Nullsv);
381 if (s->var && s->cnt > 0)
383 SvREFCNT_dec(s->var);
386 return (result) ? SvIV(result) : 0;
390 PerlIOVia_get_base(PerlIO *f)
392 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
394 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
397 return (STDCHAR *)SvPVX(s->var);
400 return (STDCHAR *) Nullch;
404 PerlIOVia_get_ptr(PerlIO *f)
406 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
408 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
411 STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
415 return (STDCHAR *) Nullch;
419 PerlIOVia_get_cnt(PerlIO *f)
421 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
423 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
433 PerlIOVia_bufsiz(PerlIO *f)
435 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
437 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
439 return SvCUR(s->var);
445 PerlIOVia_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
447 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
452 PerlIOVia_setlinebuf(PerlIO *f)
455 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
456 PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
457 PerlIOBase_setlinebuf(f);
461 PerlIOVia_clearerr(PerlIO *f)
464 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
465 PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
466 PerlIOBase_clearerr(f);
470 PerlIOVia_getarg(PerlIO *f)
473 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
474 return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
478 PerlIOVia_error(PerlIO *f)
481 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
482 SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
483 return (result) ? SvIV(result) : PerlIOBase_error(f);
487 PerlIOVia_eof(PerlIO *f)
490 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
491 SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
492 return (result) ? SvIV(result) : PerlIOBase_eof(f);
495 PerlIO_funcs PerlIO_object = {
498 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
501 NULL, /* PerlIOVia_open, */
515 PerlIOVia_setlinebuf,
520 PerlIOVia_set_ptrcnt,
524 #endif /* Layers available */
526 MODULE = PerlIO::Via PACKAGE = PerlIO::Via
532 PerlIO_define_layer(aTHX_ &PerlIO_object);