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);
50 return *save = GvCV(gv);
53 return *save = (CV *) - 1;
58 * Try and call method, possibly via cached lookup.
59 * If method does not exist return Nullsv (caller may fallback to another approach
60 * If method does exist call it with flags passing variable number of args
61 * Last arg is a "filehandle" to layer below (if present)
62 * Returns scalar returned by method (if any) otherwise sv_undef
66 PerlIOVia_method(pTHX_ PerlIO * f, char *method, CV ** save, int flags,
69 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
71 (*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s, method, save);
75 if (cv != (CV *) - 1) {
79 PUSHSTACKi(PERLSI_MAGIC);
84 while ((arg = va_arg(ap, SV *))) {
89 GV *gv = newGVgen(HvNAME(s->stash));
91 s->fh = newRV_noinc((SV *) gv);
94 IoIFP(s->io) = PerlIONext(f);
95 IoOFP(s->io) = PerlIONext(f);
99 PerlIO_debug("No next\n");
100 /* FIXME: How should this work for OPEN etc? */
103 count = call_sv((SV *) cv, flags);
110 result = &PL_sv_undef;
120 PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
123 IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
125 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
127 if (ckWARN(WARN_LAYER))
128 Perl_warner(aTHX_ packWARN(WARN_LAYER),
129 "No package specified");
135 char *pkg = SvPV(arg, pkglen);
136 s->obj = SvREFCNT_inc(arg);
137 s->stash = gv_stashpvn(pkg, pkglen, FALSE);
140 newSVpvn(Perl_form(aTHX_ "PerlIO::via::%s", pkg),
143 s->stash = gv_stashpvn(SvPVX(s->obj), pkglen + 13, FALSE);
150 /* binmode() passes NULL - so find out what mode is */
151 mode = PerlIO_modestr(f,lmode);
153 modesv = sv_2mortal(newSVpvn(mode, strlen(mode)));
154 result = PerlIOVia_method(aTHX_ f, MYMethod(PUSHED), G_SCALAR,
157 if (sv_isobject(result)) {
158 s->obj = SvREFCNT_inc(result);
161 else if (SvIV(result) != 0)
167 if (PerlIOVia_fetchmethod(aTHX_ s, MYMethod(FILL)) ==
169 PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
171 PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
174 if (ckWARN(WARN_LAYER))
175 Perl_warner(aTHX_ packWARN(WARN_LAYER),
176 "Cannot find package '%.*s'", (int) pkglen,
194 PerlIOVia_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers,
195 IV n, const char *mode, int fd, int imode, int perm,
196 PerlIO * f, int narg, SV ** args)
199 f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX), self, mode,
204 if (!PerlIO_push(aTHX_ f, self, mode, PerlIOArg))
208 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
211 SV *fdsv = sv_2mortal(newSViv(fd));
213 PerlIOVia_method(aTHX_ f, MYMethod(FDOPEN), G_SCALAR, fdsv,
218 SV *imodesv = sv_2mortal(newSViv(imode));
219 SV *permsv = sv_2mortal(newSViv(perm));
221 PerlIOVia_method(aTHX_ f, MYMethod(SYSOPEN), G_SCALAR,
222 *args, imodesv, permsv, Nullsv);
226 PerlIOVia_method(aTHX_ f, MYMethod(OPEN), G_SCALAR,
231 if (sv_isobject(result))
232 s->obj = SvREFCNT_inc(result);
233 else if (!SvTRUE(result)) {
238 /* Required open method not present */
239 PerlIO_funcs *tab = NULL;
243 PerlIO_layer_fetch(aTHX_ layers, m, NULL);
251 if ((*tab->Open) (aTHX_ tab, layers, m, mode, fd, imode,
252 perm, PerlIONext(f), narg, args)) {
253 PerlIO_debug("Opened with %s => %p->%p\n", tab->name,
254 PerlIONext(f), *PerlIONext(f));
257 * More layers above the one that we used to open -
260 if (PerlIO_apply_layera
261 (aTHX_ PerlIONext(f), mode, layers, m + 1,
263 /* If pushing layers fails close the file */
268 /* FIXME - Call an OPENED method here ? */
272 PerlIO_debug("Open fail %s => %p->%p\n", tab->name,
273 PerlIONext(f), *PerlIONext(f));
274 /* Sub-layer open failed */
278 PerlIO_debug("Nothing to open with");
279 /* Nothing to do the open */
289 PerlIOVia_popped(pTHX_ PerlIO * f)
291 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
292 PerlIOVia_method(aTHX_ f, MYMethod(POPPED), G_VOID, Nullsv);
294 SvREFCNT_dec(s->var);
308 SvREFCNT_dec(s->obj);
315 PerlIOVia_close(pTHX_ PerlIO * f)
317 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
318 IV code = PerlIOBase_close(aTHX_ f);
320 PerlIOVia_method(aTHX_ f, MYMethod(CLOSE), G_SCALAR, Nullsv);
321 if (result && SvIV(result) != 0)
323 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
328 PerlIOVia_fileno(pTHX_ PerlIO * f)
330 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
332 PerlIOVia_method(aTHX_ f, MYMethod(FILENO), G_SCALAR, Nullsv);
333 return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
337 PerlIOVia_binmode(pTHX_ PerlIO * f)
339 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
341 PerlIOVia_method(aTHX_ f, MYMethod(BINMODE), G_SCALAR, Nullsv);
342 if (!result || !SvOK(result)) {
350 PerlIOVia_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
352 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
353 SV *offsv = sv_2mortal(sizeof(Off_t) > sizeof(IV)
354 ? newSVnv((NV)offset) : newSViv((IV)offset));
355 SV *whsv = sv_2mortal(newSViv(whence));
357 PerlIOVia_method(aTHX_ f, MYMethod(SEEK), G_SCALAR, offsv, whsv,
359 #if Off_t_size == 8 && defined(CONDOP_SIZE) && CONDOP_SIZE < Off_t_size
361 return (Off_t) SvIV(result);
365 return (result) ? SvIV(result) : -1;
370 PerlIOVia_tell(pTHX_ PerlIO * f)
372 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
374 PerlIOVia_method(aTHX_ f, MYMethod(TELL), G_SCALAR, Nullsv);
376 ? (SvNOK(result) ? (Off_t)SvNV(result) : (Off_t)SvIV(result))
381 PerlIOVia_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
383 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
384 SV *buf = sv_2mortal(newSVpvn((char *) vbuf, count));
386 PerlIOVia_method(aTHX_ f, MYMethod(UNREAD), G_SCALAR, buf, Nullsv);
388 return (SSize_t) SvIV(result);
390 return PerlIOBase_unread(aTHX_ f, vbuf, count);
395 PerlIOVia_read(pTHX_ PerlIO * f, void *vbuf, Size_t count)
398 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
399 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
400 rd = PerlIOBase_read(aTHX_ f, vbuf, count);
403 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
404 SV *buf = sv_2mortal(newSV(count));
405 SV *n = sv_2mortal(newSViv(count));
407 PerlIOVia_method(aTHX_ f, MYMethod(READ), G_SCALAR, buf, n,
410 rd = (SSize_t) SvIV(result);
411 Move(SvPVX(buf), vbuf, rd, char);
420 PerlIOVia_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
422 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
423 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
424 SV *buf = newSVpvn((char *) vbuf, count);
426 PerlIOVia_method(aTHX_ f, MYMethod(WRITE), G_SCALAR, buf,
430 return (SSize_t) SvIV(result);
437 PerlIOVia_fill(pTHX_ PerlIO * f)
439 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
440 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
442 PerlIOVia_method(aTHX_ f, MYMethod(FILL), G_SCALAR, Nullsv);
444 SvREFCNT_dec(s->var);
447 if (result && SvOK(result)) {
449 char *p = SvPV(result, len);
450 s->var = newSVpvn(p, len);
451 s->cnt = SvCUR(s->var);
455 PerlIOBase(f)->flags |= PERLIO_F_EOF;
461 PerlIOVia_flush(pTHX_ PerlIO * f)
463 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
465 PerlIOVia_method(aTHX_ f, MYMethod(FLUSH), G_SCALAR, Nullsv);
466 if (s->var && s->cnt > 0) {
467 SvREFCNT_dec(s->var);
470 return (result) ? SvIV(result) : 0;
474 PerlIOVia_get_base(pTHX_ PerlIO * f)
476 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
477 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
479 return (STDCHAR *) SvPVX(s->var);
482 return (STDCHAR *) Nullch;
486 PerlIOVia_get_ptr(pTHX_ PerlIO * f)
488 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
489 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
491 STDCHAR *p = (STDCHAR *) (SvEND(s->var) - s->cnt);
495 return (STDCHAR *) Nullch;
499 PerlIOVia_get_cnt(pTHX_ PerlIO * f)
501 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
502 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
511 PerlIOVia_bufsiz(pTHX_ PerlIO * f)
513 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
514 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
516 return SvCUR(s->var);
522 PerlIOVia_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
524 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
529 PerlIOVia_setlinebuf(pTHX_ PerlIO * f)
531 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
532 PerlIOVia_method(aTHX_ f, MYMethod(SETLINEBUF), G_VOID, Nullsv);
533 PerlIOBase_setlinebuf(aTHX_ f);
537 PerlIOVia_clearerr(pTHX_ PerlIO * f)
539 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
540 PerlIOVia_method(aTHX_ f, MYMethod(CLEARERR), G_VOID, Nullsv);
541 PerlIOBase_clearerr(aTHX_ f);
545 PerlIOVia_error(pTHX_ PerlIO * f)
547 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
549 PerlIOVia_method(aTHX_ f, "ERROR", &s->mERROR, G_SCALAR, Nullsv);
550 return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
554 PerlIOVia_eof(pTHX_ PerlIO * f)
556 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
558 PerlIOVia_method(aTHX_ f, "EOF", &s->mEOF, G_SCALAR, Nullsv);
559 return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
563 PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
565 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
566 return PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
570 PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
573 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
574 /* Most of the fields will lazily set themselves up as needed
575 stash and obj have been set up by the implied push
583 PerlIO_funcs PerlIO_object = {
584 sizeof(PerlIO_funcs),
587 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
590 PerlIOVia_open, /* NULL, */
591 PerlIOVia_binmode, /* NULL, */
606 PerlIOVia_setlinebuf,
611 PerlIOVia_set_ptrcnt,
615 #endif /* Layers available */
617 MODULE = PerlIO::via PACKAGE = PerlIO::via
623 PerlIO_define_layer(aTHX_ &PerlIO_object);