1 #define PERL_NO_GET_CONTEXT
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5 #ifdef PERLIO_LAYERS
6
7 #include "perliol.h"
8
9 typedef struct
10 {
11 struct _PerlIO base; /* Base "class" info */
12 HV * stash;
13 SV * obj;
14 SV * var;
15 SSize_t cnt;
16 IO * io;
17 SV * fh;
18 CV *PUSHED;
19 CV *POPPED;
20 CV *OPEN;
21 CV *FDOPEN;
22 CV *SYSOPEN;
23 CV *GETARG;
24 CV *FILENO;
25 CV *READ;
26 CV *WRITE;
27 CV *FILL;
28 CV *CLOSE;
29 CV *SEEK;
30 CV *TELL;
31 CV *UNREAD;
32 CV *FLUSH;
33 CV *SETLINEBUF;
34 CV *CLEARERR;
35 CV *mERROR;
36 CV *mEOF;
37 CV *BINMODE;
38 CV *UTF8;
39 } PerlIOVia;
40
41 static const MGVTBL PerlIOVia_tag = { 0, 0, 0, 0, 0, 0, 0, 0 };
42
43 #define MYMethod(x) #x,&s->x
44
45 static CV *
PerlIOVia_fetchmethod(pTHX_ PerlIOVia * s,const char * method,CV ** save)46 PerlIOVia_fetchmethod(pTHX_ PerlIOVia * s, const char *method, CV ** save)
47 {
48 GV *gv = gv_fetchmeth(s->stash, method, strlen(method), 0);
49 #if 0
50 Perl_warn(aTHX_ "Lookup %s::%s => %p", HvNAME_get(s->stash), method, gv);
51 #endif
52 if (gv) {
53 return *save = GvCV(gv);
54 }
55 else {
56 return *save = (CV *) - 1;
57 }
58 }
59
60 /*
61 * Try and call method, possibly via cached lookup.
62 * If method does not exist return Nullsv (caller may fallback to another approach
63 * If method does exist call it with flags passing variable number of args
64 * Last arg is a "filehandle" to layer below (if present)
65 * Returns scalar returned by method (if any) otherwise sv_undef
66 */
67
68 static SV *
PerlIOVia_method(pTHX_ PerlIO * f,const char * method,CV ** save,int flags,...)69 PerlIOVia_method(pTHX_ PerlIO * f, const char *method, CV ** save, int flags,
70 ...)
71 {
72 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
73 SV *result = Nullsv;
74 CV *cv =
75 (*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s, method, save);
76 if (cv != (CV *) - 1) {
77 IV count;
78 dSP;
79 SV *arg;
80 va_list ap;
81
82 va_start(ap, flags);
83 PUSHSTACKi(PERLSI_MAGIC);
84 ENTER;
85 PUSHMARK(sp);
86 XPUSHs(s->obj);
87 while ((arg = va_arg(ap, SV *))) {
88 XPUSHs(arg);
89 }
90 va_end(ap);
91 if (*PerlIONext(f)) {
92 if (!s->fh) {
93 GV *gv;
94 char *package = HvNAME_get(s->stash);
95
96 if (!package)
97 return Nullsv; /* can this ever happen? */
98 gv = newGVgen(package);
99 GvIOp(gv) = newIO();
100 s->fh = newRV((SV *) gv);
101 s->io = GvIOp(gv);
102 if (gv) {
103 /* shamelessly stolen from IO::File's new_tmpfile() */
104 (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
105 }
106 }
107 IoIFP(s->io) = PerlIONext(f);
108 IoOFP(s->io) = PerlIONext(f);
109 XPUSHs(s->fh);
110 }
111 else {
112 PerlIO_debug("No next\n");
113 /* FIXME: How should this work for OPEN etc? */
114 }
115 PUTBACK;
116 count = call_sv((SV *) cv, flags);
117 if (count) {
118 SPAGAIN;
119 result = POPs;
120 PUTBACK;
121 }
122 else {
123 result = &PL_sv_undef;
124 }
125 LEAVE;
126 POPSTACK;
127 }
128 return result;
129 }
130
131 static IV
PerlIOVia_pushed(pTHX_ PerlIO * f,const char * mode,SV * arg,PerlIO_funcs * tab)132 PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
133 PerlIO_funcs * tab)
134 {
135 IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
136
137 if (arg && SvTYPE(arg) >= SVt_PVMG
138 && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) {
139 return code;
140 }
141
142 if (code == 0) {
143 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
144 if (!arg) {
145 if (ckWARN(WARN_LAYER))
146 Perl_warner(aTHX_ packWARN(WARN_LAYER),
147 "No package specified");
148 errno = EINVAL;
149 code = -1;
150 }
151 else {
152 STRLEN pkglen = 0;
153 const char *pkg = SvPV(arg, pkglen);
154 s->obj =
155 newSVpvn(Perl_form(aTHX_ "PerlIO::via::%s", pkg),
156 pkglen + 13);
157 s->stash = gv_stashpvn(SvPVX_const(s->obj), pkglen + 13, 0);
158 if (!s->stash) {
159 SvREFCNT_dec(s->obj);
160 s->obj = SvREFCNT_inc(arg);
161 s->stash = gv_stashpvn(pkg, pkglen, 0);
162 }
163 if (s->stash) {
164 char lmode[8];
165 SV *modesv;
166 SV *result;
167 if (!mode) {
168 /* binmode() passes NULL - so find out what mode is */
169 mode = PerlIO_modestr(f,lmode);
170 }
171 modesv = newSVpvn_flags(mode, strlen(mode), SVs_TEMP);
172 result = PerlIOVia_method(aTHX_ f, MYMethod(PUSHED), G_SCALAR,
173 modesv, Nullsv);
174 if (result) {
175 if (sv_isobject(result)) {
176 SvREFCNT_dec(s->obj);
177 s->obj = SvREFCNT_inc(result);
178 }
179 else if (SvIV(result) != 0)
180 return SvIV(result);
181 }
182 else {
183 goto push_failed;
184 }
185 modesv = (*PerlIONext(f) && (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_UTF8))
186 ? &PL_sv_yes : &PL_sv_no;
187 result = PerlIOVia_method(aTHX_ f, MYMethod(UTF8), G_SCALAR, modesv, Nullsv);
188 if (result && SvTRUE(result)) {
189 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
190 }
191 else {
192 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
193 }
194 if (PerlIOVia_fetchmethod(aTHX_ s, MYMethod(FILL)) ==
195 (CV *) - 1)
196 PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
197 else
198 PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
199 }
200 else {
201 if (ckWARN(WARN_LAYER))
202 Perl_warner(aTHX_ packWARN(WARN_LAYER),
203 "Cannot find package '%.*s'", (int) pkglen,
204 pkg);
205 push_failed:
206 #ifdef ENOSYS
207 errno = ENOSYS;
208 #else
209 #ifdef ENOENT
210 errno = ENOENT;
211 #endif
212 #endif
213 code = -1;
214 }
215 }
216 }
217 return code;
218 }
219
220 static PerlIO *
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)221 PerlIOVia_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers,
222 IV n, const char *mode, int fd, int imode, int perm,
223 PerlIO * f, int narg, SV ** args)
224 {
225 if (!f) {
226 f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX), self, mode,
227 PerlIOArg);
228 }
229 else {
230 /* Reopen */
231 if (!PerlIO_push(aTHX_ f, self, mode, PerlIOArg))
232 return NULL;
233 }
234 if (f) {
235 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
236 SV *result = Nullsv;
237 if (fd >= 0) {
238 SV *fdsv = sv_2mortal(newSViv(fd));
239 result =
240 PerlIOVia_method(aTHX_ f, MYMethod(FDOPEN), G_SCALAR, fdsv,
241 Nullsv);
242 }
243 else if (narg > 0) {
244 if (*mode == '#') {
245 SV *imodesv = sv_2mortal(newSViv(imode));
246 SV *permsv = sv_2mortal(newSViv(perm));
247 result =
248 PerlIOVia_method(aTHX_ f, MYMethod(SYSOPEN), G_SCALAR,
249 *args, imodesv, permsv, Nullsv);
250 }
251 else {
252 result =
253 PerlIOVia_method(aTHX_ f, MYMethod(OPEN), G_SCALAR,
254 *args, Nullsv);
255 }
256 }
257 if (result) {
258 if (sv_isobject(result))
259 s->obj = SvREFCNT_inc(result);
260 else if (!SvTRUE(result)) {
261 return NULL;
262 }
263 }
264 else {
265 /* Required open method not present */
266 PerlIO_funcs *tab = NULL;
267 IV m = n - 1;
268 while (m >= 0) {
269 PerlIO_funcs *t =
270 PerlIO_layer_fetch(aTHX_ layers, m, NULL);
271 if (t && t->Open) {
272 tab = t;
273 break;
274 }
275 m--;
276 }
277 if (tab) {
278 if ((*tab->Open) (aTHX_ tab, layers, m, mode, fd, imode,
279 perm, PerlIONext(f), narg, args)) {
280 PerlIO_debug("Opened with %s => %p->%p\n", tab->name,
281 PerlIONext(f), *PerlIONext(f));
282 if (m + 1 < n) {
283 /*
284 * More layers above the one that we used to open -
285 * apply them now
286 */
287 if (PerlIO_apply_layera
288 (aTHX_ PerlIONext(f), mode, layers, m + 1,
289 n) != 0) {
290 /* If pushing layers fails close the file */
291 PerlIO_close(f);
292 f = NULL;
293 }
294 }
295 /* FIXME - Call an OPENED method here ? */
296 return f;
297 }
298 else {
299 PerlIO_debug("Open fail %s => %p->%p\n", tab->name,
300 PerlIONext(f), *PerlIONext(f));
301 /* Sub-layer open failed */
302 }
303 }
304 else {
305 PerlIO_debug("Nothing to open with");
306 /* Nothing to do the open */
307 }
308 PerlIO_pop(aTHX_ f);
309 return NULL;
310 }
311 }
312 return f;
313 }
314
315 static IV
PerlIOVia_popped(pTHX_ PerlIO * f)316 PerlIOVia_popped(pTHX_ PerlIO * f)
317 {
318 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
319 PerlIOVia_method(aTHX_ f, MYMethod(POPPED), G_VOID, Nullsv);
320 if (s->var) {
321 SvREFCNT_dec(s->var);
322 s->var = Nullsv;
323 }
324
325 if (s->io) {
326 IoIFP(s->io) = NULL;
327 IoOFP(s->io) = NULL;
328 }
329 if (s->fh) {
330 SvREFCNT_dec(s->fh);
331 s->fh = Nullsv;
332 s->io = NULL;
333 }
334 if (s->obj) {
335 SvREFCNT_dec(s->obj);
336 s->obj = Nullsv;
337 }
338 return 0;
339 }
340
341 static IV
PerlIOVia_close(pTHX_ PerlIO * f)342 PerlIOVia_close(pTHX_ PerlIO * f)
343 {
344 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
345 IV code = PerlIOBase_close(aTHX_ f);
346 SV *result =
347 PerlIOVia_method(aTHX_ f, MYMethod(CLOSE), G_SCALAR, Nullsv);
348 if (result && SvIV(result) != 0)
349 code = SvIV(result);
350 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
351 return code;
352 }
353
354 static IV
PerlIOVia_fileno(pTHX_ PerlIO * f)355 PerlIOVia_fileno(pTHX_ PerlIO * f)
356 {
357 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
358 SV *result =
359 PerlIOVia_method(aTHX_ f, MYMethod(FILENO), G_SCALAR, Nullsv);
360 return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
361 }
362
363 static IV
PerlIOVia_binmode(pTHX_ PerlIO * f)364 PerlIOVia_binmode(pTHX_ PerlIO * f)
365 {
366 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
367 SV *result =
368 PerlIOVia_method(aTHX_ f, MYMethod(BINMODE), G_SCALAR, Nullsv);
369 if (!result || !SvOK(result)) {
370 PerlIO_pop(aTHX_ f);
371 return 0;
372 }
373 return SvIV(result);
374 }
375
376 static IV
PerlIOVia_seek(pTHX_ PerlIO * f,Off_t offset,int whence)377 PerlIOVia_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
378 {
379 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
380 SV *offsv = sv_2mortal(sizeof(Off_t) > sizeof(IV)
381 ? newSVnv((NV)offset) : newSViv((IV)offset));
382 SV *whsv = sv_2mortal(newSViv(whence));
383 SV *result =
384 PerlIOVia_method(aTHX_ f, MYMethod(SEEK), G_SCALAR, offsv, whsv,
385 Nullsv);
386 #if Off_t_size == 8 && defined(CONDOP_SIZE) && CONDOP_SIZE < Off_t_size
387 if (result)
388 return (Off_t) SvIV(result);
389 else
390 return (Off_t) -1;
391 #else
392 return (result) ? SvIV(result) : -1;
393 #endif
394 }
395
396 static Off_t
PerlIOVia_tell(pTHX_ PerlIO * f)397 PerlIOVia_tell(pTHX_ PerlIO * f)
398 {
399 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
400 SV *result =
401 PerlIOVia_method(aTHX_ f, MYMethod(TELL), G_SCALAR, Nullsv);
402 return (result)
403 ? (SvNOK(result) ? (Off_t)SvNV(result) : (Off_t)SvIV(result))
404 : (Off_t) - 1;
405 }
406
407 static SSize_t
PerlIOVia_unread(pTHX_ PerlIO * f,const void * vbuf,Size_t count)408 PerlIOVia_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
409 {
410 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
411 SV *buf = newSVpvn_flags((char *) vbuf, count, SVs_TEMP);
412 SV *result =
413 PerlIOVia_method(aTHX_ f, MYMethod(UNREAD), G_SCALAR, buf, Nullsv);
414 if (result)
415 return (SSize_t) SvIV(result);
416 else {
417 return PerlIOBase_unread(aTHX_ f, vbuf, count);
418 }
419 }
420
421 static SSize_t
PerlIOVia_read(pTHX_ PerlIO * f,void * vbuf,Size_t count)422 PerlIOVia_read(pTHX_ PerlIO * f, void *vbuf, Size_t count)
423 {
424 SSize_t rd = 0;
425 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
426 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
427 rd = PerlIOBase_read(aTHX_ f, vbuf, count);
428 }
429 else {
430 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
431 SV *buf = sv_2mortal(newSV(count));
432 SV *n = sv_2mortal(newSViv(count));
433 SV *result =
434 PerlIOVia_method(aTHX_ f, MYMethod(READ), G_SCALAR, buf, n,
435 Nullsv);
436 if (result) {
437 rd = (SSize_t) SvIV(result);
438 Move(SvPVX(buf), vbuf, rd, char);
439 return rd;
440 }
441 }
442 }
443 return rd;
444 }
445
446 static SSize_t
PerlIOVia_write(pTHX_ PerlIO * f,const void * vbuf,Size_t count)447 PerlIOVia_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
448 {
449 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
450 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
451 SV *buf = newSVpvn((char *) vbuf, count);
452 SV *result =
453 PerlIOVia_method(aTHX_ f, MYMethod(WRITE), G_SCALAR, buf,
454 Nullsv);
455 SvREFCNT_dec(buf);
456 if (result)
457 return (SSize_t) SvIV(result);
458 return -1;
459 }
460 return 0;
461 }
462
463 static IV
PerlIOVia_fill(pTHX_ PerlIO * f)464 PerlIOVia_fill(pTHX_ PerlIO * f)
465 {
466 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
467 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
468 SV *result =
469 PerlIOVia_method(aTHX_ f, MYMethod(FILL), G_SCALAR, Nullsv);
470 if (s->var) {
471 SvREFCNT_dec(s->var);
472 s->var = Nullsv;
473 }
474 if (result && SvOK(result)) {
475 STRLEN len = 0;
476 const char *p = SvPV(result, len);
477 s->var = newSVpvn(p, len);
478 s->cnt = SvCUR(s->var);
479 return 0;
480 }
481 else
482 PerlIOBase(f)->flags |= PERLIO_F_EOF;
483 }
484 return -1;
485 }
486
487 static IV
PerlIOVia_flush(pTHX_ PerlIO * f)488 PerlIOVia_flush(pTHX_ PerlIO * f)
489 {
490 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
491 SV *result =
492 PerlIOVia_method(aTHX_ f, MYMethod(FLUSH), G_SCALAR, Nullsv);
493 if (s->var && s->cnt > 0) {
494 SvREFCNT_dec(s->var);
495 s->var = Nullsv;
496 }
497 return (result) ? SvIV(result) : 0;
498 }
499
500 static STDCHAR *
PerlIOVia_get_base(pTHX_ PerlIO * f)501 PerlIOVia_get_base(pTHX_ PerlIO * f)
502 {
503 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
504 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
505 if (s->var) {
506 return (STDCHAR *) SvPVX(s->var);
507 }
508 }
509 return (STDCHAR *) NULL;
510 }
511
512 static STDCHAR *
PerlIOVia_get_ptr(pTHX_ PerlIO * f)513 PerlIOVia_get_ptr(pTHX_ PerlIO * f)
514 {
515 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
516 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
517 if (s->var) {
518 STDCHAR *p = (STDCHAR *) (SvEND(s->var) - s->cnt);
519 return p;
520 }
521 }
522 return (STDCHAR *) NULL;
523 }
524
525 static SSize_t
PerlIOVia_get_cnt(pTHX_ PerlIO * f)526 PerlIOVia_get_cnt(pTHX_ PerlIO * f)
527 {
528 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
529 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
530 if (s->var) {
531 return s->cnt;
532 }
533 }
534 return 0;
535 }
536
537 static Size_t
PerlIOVia_bufsiz(pTHX_ PerlIO * f)538 PerlIOVia_bufsiz(pTHX_ PerlIO * f)
539 {
540 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
541 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
542 if (s->var)
543 return SvCUR(s->var);
544 }
545 return 0;
546 }
547
548 static void
PerlIOVia_set_ptrcnt(pTHX_ PerlIO * f,STDCHAR * ptr,SSize_t cnt)549 PerlIOVia_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
550 {
551 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
552 PERL_UNUSED_ARG(ptr);
553 s->cnt = cnt;
554 }
555
556 static void
PerlIOVia_setlinebuf(pTHX_ PerlIO * f)557 PerlIOVia_setlinebuf(pTHX_ PerlIO * f)
558 {
559 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
560 PerlIOVia_method(aTHX_ f, MYMethod(SETLINEBUF), G_VOID, Nullsv);
561 PerlIOBase_setlinebuf(aTHX_ f);
562 }
563
564 static void
PerlIOVia_clearerr(pTHX_ PerlIO * f)565 PerlIOVia_clearerr(pTHX_ PerlIO * f)
566 {
567 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
568 PerlIOVia_method(aTHX_ f, MYMethod(CLEARERR), G_VOID, Nullsv);
569 PerlIOBase_clearerr(aTHX_ f);
570 }
571
572 static IV
PerlIOVia_error(pTHX_ PerlIO * f)573 PerlIOVia_error(pTHX_ PerlIO * f)
574 {
575 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
576 SV *result =
577 PerlIOVia_method(aTHX_ f, "ERROR", &s->mERROR, G_SCALAR, Nullsv);
578 return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
579 }
580
581 static IV
PerlIOVia_eof(pTHX_ PerlIO * f)582 PerlIOVia_eof(pTHX_ PerlIO * f)
583 {
584 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
585 SV *result =
586 PerlIOVia_method(aTHX_ f, "EOF", &s->mEOF, G_SCALAR, Nullsv);
587 return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
588 }
589
590 static SV *
PerlIOVia_getarg(pTHX_ PerlIO * f,CLONE_PARAMS * param,int flags)591 PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
592 {
593 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
594 SV *arg;
595 PERL_UNUSED_ARG(flags);
596
597 /* During cloning, return an undef token object so that _pushed() knows
598 * that it should not call methods and wait for _dup() to actually dup the
599 * object. */
600 if (param) {
601 SV *sv = newSV(0);
602 sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOVia_tag, 0, 0);
603 return sv;
604 }
605
606 arg = PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
607 if (arg) {
608 /* arg is a temp, and PerlIOBase_dup() will explicitly free it */
609 SvREFCNT_inc(arg);
610 }
611 else {
612 arg = newSVpvn(HvNAME(s->stash), HvNAMELEN(s->stash));
613 }
614
615 return arg;
616 }
617
618 static PerlIO *
PerlIOVia_dup(pTHX_ PerlIO * f,PerlIO * o,CLONE_PARAMS * param,int flags)619 PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
620 int flags)
621 {
622 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
623 #ifdef USE_ITHREADS
624 if (param) {
625 /* For a non-interpreter dup stash and obj have been set up
626 by the implied push.
627
628 But if this is a clone for a new interpreter we need to
629 translate the objects to their dups.
630 */
631
632 PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
633 PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
634
635 fs->obj = sv_dup_inc(os->obj, param);
636 fs->stash = (HV*)sv_dup((SV*)os->stash, param);
637 fs->var = sv_dup_inc(os->var, param);
638 fs->cnt = os->cnt;
639
640 /* fh, io, cached CVs left as NULL, PerlIOVia_method()
641 will reinitialize them if needed */
642 }
643 #endif
644 /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
645 }
646
647 return f;
648 }
649
650
651
652 static PERLIO_FUNCS_DECL(PerlIO_object) = {
653 sizeof(PerlIO_funcs),
654 "via",
655 sizeof(PerlIOVia),
656 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
657 PerlIOVia_pushed,
658 PerlIOVia_popped,
659 PerlIOVia_open, /* NULL, */
660 PerlIOVia_binmode, /* NULL, */
661 PerlIOVia_getarg,
662 PerlIOVia_fileno,
663 PerlIOVia_dup,
664 PerlIOVia_read,
665 PerlIOVia_unread,
666 PerlIOVia_write,
667 PerlIOVia_seek,
668 PerlIOVia_tell,
669 PerlIOVia_close,
670 PerlIOVia_flush,
671 PerlIOVia_fill,
672 PerlIOVia_eof,
673 PerlIOVia_error,
674 PerlIOVia_clearerr,
675 PerlIOVia_setlinebuf,
676 PerlIOVia_get_base,
677 PerlIOVia_bufsiz,
678 PerlIOVia_get_ptr,
679 PerlIOVia_get_cnt,
680 PerlIOVia_set_ptrcnt,
681 };
682
683
684 #endif /* Layers available */
685
686 MODULE = PerlIO::via PACKAGE = PerlIO::via
687 PROTOTYPES: ENABLE;
688
689 BOOT:
690 {
691 #ifdef PERLIO_LAYERS
692 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_object));
693 #endif
694 }
695
696
697
698
699
700