1 #define PERL_NO_GET_CONTEXT
11 struct _PerlIO base; /* Base "class" info */
39 #define MYMethod(x) #x,&s->x
42 PerlIOVia_fetchmethod(pTHX_ PerlIOVia *s,char *method,CV **save)
44 GV *gv = gv_fetchmeth(s->stash,method,strlen(method),0);
46 Perl_warn(aTHX_ "Lookup %s::%s => %p",HvNAME(s->stash),method,gv);
50 return *save = GvCV(gv);
54 return *save = (CV *) -1;
59 PerlIOVia_method(pTHX_ PerlIO *f,char *method,CV **save,int flags,...)
61 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
62 CV *cv = (*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s,method,save);
74 while ((arg = va_arg(ap,SV *)))
82 GV *gv = newGVgen(HvNAME(s->stash));
84 s->fh = newRV_noinc((SV *)gv);
87 IoIFP(s->io) = PerlIONext(f);
88 IoOFP(s->io) = PerlIONext(f);
92 count = call_sv((SV *)cv,flags);
101 result = &PL_sv_undef;
110 PerlIOVia_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
112 IV code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv);
115 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
118 if (ckWARN(WARN_LAYER))
119 Perl_warner(aTHX_ packWARN(WARN_LAYER), "No package specified");
125 char *pkg = SvPV(arg,pkglen);
126 s->obj = SvREFCNT_inc(arg);
127 s->stash = gv_stashpvn(pkg, pkglen, FALSE);
130 SV *modesv = (mode) ? sv_2mortal(newSVpvn(mode,strlen(mode))) : Nullsv;
131 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(PUSHED),G_SCALAR,modesv,Nullsv);
134 if (sv_isobject(result))
136 s->obj = SvREFCNT_inc(result);
139 else if (SvIV(result) != 0)
142 if (PerlIOVia_fetchmethod(aTHX_ s,MYMethod(FILL)) == (CV *) -1)
143 PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
145 PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
149 if (ckWARN(WARN_LAYER))
150 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Cannot find package '%.*s'",(int) pkglen,pkg);
166 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)
170 f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX),self,mode,PerlIOArg);
174 if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
179 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
183 SV *fdsv = sv_2mortal(newSViv(fd));
184 result = PerlIOVia_method(aTHX_ f,MYMethod(FDOPEN),G_SCALAR,fdsv,Nullsv);
190 SV *imodesv = sv_2mortal(newSViv(imode));
191 SV *permsv = sv_2mortal(newSViv(perm));
192 result = PerlIOVia_method(aTHX_ f,MYMethod(SYSOPEN),G_SCALAR,*args,imodesv,permsv,Nullsv);
196 result = PerlIOVia_method(aTHX_ f,MYMethod(OPEN),G_SCALAR,*args,Nullsv);
201 if (sv_isobject(result))
202 s->obj = SvREFCNT_inc(result);
203 else if (!SvTRUE(result))
215 PerlIOVia_popped(pTHX_ PerlIO *f)
217 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
218 PerlIOVia_method(aTHX_ f,MYMethod(POPPED),G_VOID,Nullsv);
221 SvREFCNT_dec(s->var);
238 SvREFCNT_dec(s->obj);
245 PerlIOVia_close(pTHX_ PerlIO *f)
247 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
248 IV code = PerlIOBase_close(aTHX_ f);
249 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(CLOSE),G_SCALAR,Nullsv);
250 if (result && SvIV(result) != 0)
252 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
257 PerlIOVia_fileno(pTHX_ PerlIO *f)
259 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
260 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILENO),G_SCALAR,Nullsv);
261 return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
265 PerlIOVia_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
267 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
268 SV *offsv = sv_2mortal(newSViv(offset));
269 SV *whsv = sv_2mortal(newSViv(whence));
270 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
271 return (result) ? SvIV(result) : -1;
275 PerlIOVia_tell(pTHX_ PerlIO *f)
277 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
278 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
279 return (result) ? (Off_t) SvIV(result) : (Off_t) -1;
283 PerlIOVia_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
285 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
286 SV *buf = sv_2mortal(newSVpvn((char *)vbuf,count));
287 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(UNREAD),G_SCALAR,buf,Nullsv);
289 return (SSize_t) SvIV(result);
292 return PerlIOBase_unread(aTHX_ f,vbuf,count);
297 PerlIOVia_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
300 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
302 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)
304 rd = PerlIOBase_read(aTHX_ f,vbuf,count);
308 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
309 SV *buf = sv_2mortal(newSV(count));
310 SV *n = sv_2mortal(newSViv(count));
311 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(READ),G_SCALAR,buf,n,Nullsv);
314 rd = (SSize_t) SvIV(result);
315 Move(SvPVX(buf),vbuf,rd,char);
324 PerlIOVia_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
326 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
328 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
329 SV *buf = newSVpvn((char *)vbuf,count);
330 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(WRITE),G_SCALAR,buf,Nullsv);
333 return (SSize_t) SvIV(result);
340 PerlIOVia_fill(pTHX_ PerlIO *f)
342 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
344 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
345 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILL),G_SCALAR,Nullsv);
348 SvREFCNT_dec(s->var);
351 if (result && SvOK(result))
354 char *p = SvPV(result,len);
355 s->var = newSVpvn(p,len);
356 s->cnt = SvCUR(s->var);
360 PerlIOBase(f)->flags |= PERLIO_F_EOF;
366 PerlIOVia_flush(pTHX_ PerlIO *f)
368 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
369 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FLUSH),G_SCALAR,Nullsv);
370 if (s->var && s->cnt > 0)
372 SvREFCNT_dec(s->var);
375 return (result) ? SvIV(result) : 0;
379 PerlIOVia_get_base(pTHX_ PerlIO *f)
381 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
383 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
386 return (STDCHAR *)SvPVX(s->var);
389 return (STDCHAR *) Nullch;
393 PerlIOVia_get_ptr(pTHX_ PerlIO *f)
395 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
397 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
400 STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
404 return (STDCHAR *) Nullch;
408 PerlIOVia_get_cnt(pTHX_ PerlIO *f)
410 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
412 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
422 PerlIOVia_bufsiz(pTHX_ PerlIO *f)
424 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
426 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
428 return SvCUR(s->var);
434 PerlIOVia_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR *ptr, SSize_t cnt)
436 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
441 PerlIOVia_setlinebuf(pTHX_ PerlIO *f)
443 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
444 PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
445 PerlIOBase_setlinebuf(aTHX_ f);
449 PerlIOVia_clearerr(pTHX_ PerlIO *f)
451 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
452 PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
453 PerlIOBase_clearerr(aTHX_ f);
457 PerlIOVia_error(pTHX_ PerlIO *f)
459 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
460 SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
461 return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
465 PerlIOVia_eof(pTHX_ PerlIO *f)
467 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
468 SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
469 return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
473 PerlIOVia_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
475 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
476 return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
480 PerlIOVia_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
482 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)))
484 /* Most of the fields will lazily set themselves up as needed
485 stash and obj have been set up by the implied push
491 PerlIO_funcs PerlIO_object = {
494 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
497 NULL, /* PerlIOVia_open, */
512 PerlIOVia_setlinebuf,
517 PerlIOVia_set_ptrcnt,
521 #endif /* Layers available */
523 MODULE = PerlIO::Via PACKAGE = PerlIO::Via
529 PerlIO_define_layer(aTHX_ &PerlIO_object);