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 * Try and call method, possibly via cached lookup.
60 * If method does not exist return Nullsv (caller may fallback to another approach
61 * If method does exist call it with flags passing variable number of args
62 * Last arg is a "filehandle" to layer below (if present)
63 * Returns scalar returned by method (if any) otherwise sv_undef
67 PerlIOVia_method(pTHX_ PerlIO *f,char *method,CV **save,int flags,...)
69 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
70 CV *cv = (*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s,method,save);
79 PUSHSTACKi(PERLSI_MAGIC);
84 while ((arg = va_arg(ap,SV *)))
92 GV *gv = newGVgen(HvNAME(s->stash));
94 s->fh = newRV_noinc((SV *)gv);
97 IoIFP(s->io) = PerlIONext(f);
98 IoOFP(s->io) = PerlIONext(f);
103 PerlIO_debug("No next\n");
106 count = call_sv((SV *)cv,flags);
115 result = &PL_sv_undef;
125 PerlIOVia_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
127 IV code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv);
130 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
133 if (ckWARN(WARN_LAYER))
134 Perl_warner(aTHX_ packWARN(WARN_LAYER), "No package specified");
141 char *pkg = SvPV(arg,pkglen);
142 s->obj = SvREFCNT_inc(arg);
143 s->stash = gv_stashpvn(pkg, pkglen, FALSE);
146 SV *modesv = (mode) ? sv_2mortal(newSVpvn(mode,strlen(mode))) : Nullsv;
147 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(PUSHED),G_SCALAR,modesv,Nullsv);
150 if (sv_isobject(result))
152 s->obj = SvREFCNT_inc(result);
155 else if (SvIV(result) != 0)
158 if (PerlIOVia_fetchmethod(aTHX_ s,MYMethod(FILL)) == (CV *) -1)
159 PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
161 PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
165 if (ckWARN(WARN_LAYER))
166 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Cannot find package '%.*s'",(int) pkglen,pkg);
182 PerlIOVia_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n,
183 const char *mode, int fd, int imode, int perm,
184 PerlIO *f, int narg, SV **args)
188 f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX),self,mode,PerlIOArg);
193 if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
198 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
202 SV *fdsv = sv_2mortal(newSViv(fd));
203 result = PerlIOVia_method(aTHX_ f,MYMethod(FDOPEN),G_SCALAR,fdsv,Nullsv);
209 SV *imodesv = sv_2mortal(newSViv(imode));
210 SV *permsv = sv_2mortal(newSViv(perm));
211 result = PerlIOVia_method(aTHX_ f,MYMethod(SYSOPEN),G_SCALAR,*args,imodesv,permsv,Nullsv);
215 result = PerlIOVia_method(aTHX_ f,MYMethod(OPEN),G_SCALAR,*args,Nullsv);
220 if (sv_isobject(result))
221 s->obj = SvREFCNT_inc(result);
222 else if (!SvTRUE(result))
229 /* Required open method not present */
230 PerlIO_funcs *tab = NULL;
233 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layers, m, NULL);
241 if ((*tab->Open) (aTHX_ tab, layers, m, mode, fd, imode, perm,
242 PerlIONext(f), narg, args)) {
243 PerlIO_debug("Opened with %s => %p->%p\n",tab->name,PerlIONext(f),*PerlIONext(f));
246 * More layers above the one that we used to open -
249 if (PerlIO_apply_layera(aTHX_ PerlIONext(f), mode, layers, m+1, n) != 0) {
250 /* If pushing layers fails close the file */
258 /* Sub-layer open failed */
262 /* Nothing to do the open */
271 PerlIOVia_popped(pTHX_ PerlIO *f)
273 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
274 PerlIOVia_method(aTHX_ f,MYMethod(POPPED),G_VOID,Nullsv);
277 SvREFCNT_dec(s->var);
294 SvREFCNT_dec(s->obj);
301 PerlIOVia_close(pTHX_ PerlIO *f)
303 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
304 IV code = PerlIOBase_close(aTHX_ f);
305 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(CLOSE),G_SCALAR,Nullsv);
306 if (result && SvIV(result) != 0)
308 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
313 PerlIOVia_fileno(pTHX_ PerlIO *f)
315 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
316 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILENO),G_SCALAR,Nullsv);
317 return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
321 PerlIOVia_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
323 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
324 SV *offsv = sv_2mortal(newSViv(offset));
325 SV *whsv = sv_2mortal(newSViv(whence));
326 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
327 return (result) ? SvIV(result) : -1;
331 PerlIOVia_tell(pTHX_ PerlIO *f)
333 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
334 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
335 return (result) ? (Off_t) SvIV(result) : (Off_t) -1;
339 PerlIOVia_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
341 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
342 SV *buf = sv_2mortal(newSVpvn((char *)vbuf,count));
343 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(UNREAD),G_SCALAR,buf,Nullsv);
345 return (SSize_t) SvIV(result);
348 return PerlIOBase_unread(aTHX_ f,vbuf,count);
353 PerlIOVia_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
356 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
358 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)
360 rd = PerlIOBase_read(aTHX_ f,vbuf,count);
364 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
365 SV *buf = sv_2mortal(newSV(count));
366 SV *n = sv_2mortal(newSViv(count));
367 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(READ),G_SCALAR,buf,n,Nullsv);
370 rd = (SSize_t) SvIV(result);
371 Move(SvPVX(buf),vbuf,rd,char);
380 PerlIOVia_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
382 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
384 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
385 SV *buf = newSVpvn((char *)vbuf,count);
386 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(WRITE),G_SCALAR,buf,Nullsv);
389 return (SSize_t) SvIV(result);
396 PerlIOVia_fill(pTHX_ PerlIO *f)
398 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
400 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
401 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILL),G_SCALAR,Nullsv);
404 SvREFCNT_dec(s->var);
407 if (result && SvOK(result))
410 char *p = SvPV(result,len);
411 s->var = newSVpvn(p,len);
412 s->cnt = SvCUR(s->var);
416 PerlIOBase(f)->flags |= PERLIO_F_EOF;
422 PerlIOVia_flush(pTHX_ PerlIO *f)
424 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
425 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FLUSH),G_SCALAR,Nullsv);
426 if (s->var && s->cnt > 0)
428 SvREFCNT_dec(s->var);
431 return (result) ? SvIV(result) : 0;
435 PerlIOVia_get_base(pTHX_ PerlIO *f)
437 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
439 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
442 return (STDCHAR *)SvPVX(s->var);
445 return (STDCHAR *) Nullch;
449 PerlIOVia_get_ptr(pTHX_ PerlIO *f)
451 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
453 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
456 STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
460 return (STDCHAR *) Nullch;
464 PerlIOVia_get_cnt(pTHX_ PerlIO *f)
466 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
468 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
478 PerlIOVia_bufsiz(pTHX_ PerlIO *f)
480 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
482 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
484 return SvCUR(s->var);
490 PerlIOVia_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR *ptr, SSize_t cnt)
492 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
497 PerlIOVia_setlinebuf(pTHX_ PerlIO *f)
499 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
500 PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
501 PerlIOBase_setlinebuf(aTHX_ f);
505 PerlIOVia_clearerr(pTHX_ PerlIO *f)
507 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
508 PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
509 PerlIOBase_clearerr(aTHX_ f);
513 PerlIOVia_error(pTHX_ PerlIO *f)
515 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
516 SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
517 return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
521 PerlIOVia_eof(pTHX_ PerlIO *f)
523 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
524 SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
525 return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
529 PerlIOVia_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
531 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
532 return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
536 PerlIOVia_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
538 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)))
540 /* Most of the fields will lazily set themselves up as needed
541 stash and obj have been set up by the implied push
547 PerlIO_funcs PerlIO_object = {
550 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
553 PerlIOVia_open, /* NULL, */
568 PerlIOVia_setlinebuf,
573 PerlIOVia_set_ptrcnt,
577 #endif /* Layers available */
579 MODULE = PerlIO::Via PACKAGE = PerlIO::Via
585 PerlIO_define_layer(aTHX_ &PerlIO_object);