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 /* QP appears to use undef to indicate an error here */
437 if (result && SvOK(result)) {
438 rd = (SSize_t) SvIV(result);
439 STRLEN buflen = SvCUR(buf);
440 STRLEN max = buflen < count ? buflen : count;
441 if (rd < 0 || (STRLEN)rd > max) {
442 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
443 if (rd > 0 && (STRLEN)rd <= count && (STRLEN)rd > buflen) {
444 Perl_warn(aTHX_ "Invalid return from %s::READ = %zd, beyond end of the returned buffer at %zu",
445 HvNAME(s->stash), rd, buflen);
446 }
447 else {
448 Perl_warn(aTHX_ "Invalid return from %s::READ = %zd, expected undef or 0 to %zu",
449 HvNAME(s->stash), rd, count);
450 }
451 SETERRNO(EINVAL,LIB_INVARG);
452 return -1;
453 }
454
455 Move(SvPVX(buf), vbuf, rd, char);
456 return rd;
457 }
458 else {
459 return -1;
460 }
461 }
462 }
463 return rd;
464 }
465
466 static SSize_t
PerlIOVia_write(pTHX_ PerlIO * f,const void * vbuf,Size_t count)467 PerlIOVia_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
468 {
469 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
470 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
471 SV *buf = newSVpvn((char *) vbuf, count);
472 SV *result =
473 PerlIOVia_method(aTHX_ f, MYMethod(WRITE), G_SCALAR, buf,
474 Nullsv);
475 SvREFCNT_dec(buf);
476 if (result)
477 return (SSize_t) SvIV(result);
478 return -1;
479 }
480 return 0;
481 }
482
483 static IV
PerlIOVia_fill(pTHX_ PerlIO * f)484 PerlIOVia_fill(pTHX_ PerlIO * f)
485 {
486 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
487 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
488 SV *result =
489 PerlIOVia_method(aTHX_ f, MYMethod(FILL), G_SCALAR, Nullsv);
490 if (s->var) {
491 SvREFCNT_dec(s->var);
492 s->var = Nullsv;
493 }
494 if (result && SvOK(result)) {
495 STRLEN len = 0;
496 const char *p = SvPV(result, len);
497 s->var = newSVpvn(p, len);
498 s->cnt = SvCUR(s->var);
499 return 0;
500 }
501 else
502 PerlIOBase(f)->flags |= PERLIO_F_EOF;
503 }
504 return -1;
505 }
506
507 static IV
PerlIOVia_flush(pTHX_ PerlIO * f)508 PerlIOVia_flush(pTHX_ PerlIO * f)
509 {
510 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
511 SV *result =
512 PerlIOVia_method(aTHX_ f, MYMethod(FLUSH), G_SCALAR, Nullsv);
513 if (s->var && s->cnt > 0) {
514 SvREFCNT_dec(s->var);
515 s->var = Nullsv;
516 }
517 return (result) ? SvIV(result) : 0;
518 }
519
520 static STDCHAR *
PerlIOVia_get_base(pTHX_ PerlIO * f)521 PerlIOVia_get_base(pTHX_ PerlIO * f)
522 {
523 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
524 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
525 if (s->var) {
526 return (STDCHAR *) SvPVX(s->var);
527 }
528 }
529 return (STDCHAR *) NULL;
530 }
531
532 static STDCHAR *
PerlIOVia_get_ptr(pTHX_ PerlIO * f)533 PerlIOVia_get_ptr(pTHX_ PerlIO * f)
534 {
535 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
536 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
537 if (s->var) {
538 STDCHAR *p = (STDCHAR *) (SvEND(s->var) - s->cnt);
539 return p;
540 }
541 }
542 return (STDCHAR *) NULL;
543 }
544
545 static SSize_t
PerlIOVia_get_cnt(pTHX_ PerlIO * f)546 PerlIOVia_get_cnt(pTHX_ PerlIO * f)
547 {
548 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
549 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
550 if (s->var) {
551 return s->cnt;
552 }
553 }
554 return 0;
555 }
556
557 static Size_t
PerlIOVia_bufsiz(pTHX_ PerlIO * f)558 PerlIOVia_bufsiz(pTHX_ PerlIO * f)
559 {
560 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
561 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
562 if (s->var)
563 return SvCUR(s->var);
564 }
565 return 0;
566 }
567
568 static void
PerlIOVia_set_ptrcnt(pTHX_ PerlIO * f,STDCHAR * ptr,SSize_t cnt)569 PerlIOVia_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
570 {
571 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
572 PERL_UNUSED_ARG(ptr);
573 s->cnt = cnt;
574 }
575
576 static void
PerlIOVia_setlinebuf(pTHX_ PerlIO * f)577 PerlIOVia_setlinebuf(pTHX_ PerlIO * f)
578 {
579 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
580 PerlIOVia_method(aTHX_ f, MYMethod(SETLINEBUF), G_VOID, Nullsv);
581 PerlIOBase_setlinebuf(aTHX_ f);
582 }
583
584 static void
PerlIOVia_clearerr(pTHX_ PerlIO * f)585 PerlIOVia_clearerr(pTHX_ PerlIO * f)
586 {
587 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
588 PerlIOVia_method(aTHX_ f, MYMethod(CLEARERR), G_VOID, Nullsv);
589 PerlIOBase_clearerr(aTHX_ f);
590 }
591
592 static IV
PerlIOVia_error(pTHX_ PerlIO * f)593 PerlIOVia_error(pTHX_ PerlIO * f)
594 {
595 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
596 SV *result =
597 PerlIOVia_method(aTHX_ f, "ERROR", &s->mERROR, G_SCALAR, Nullsv);
598 return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
599 }
600
601 static IV
PerlIOVia_eof(pTHX_ PerlIO * f)602 PerlIOVia_eof(pTHX_ PerlIO * f)
603 {
604 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
605 SV *result =
606 PerlIOVia_method(aTHX_ f, "EOF", &s->mEOF, G_SCALAR, Nullsv);
607 return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
608 }
609
610 static SV *
PerlIOVia_getarg(pTHX_ PerlIO * f,CLONE_PARAMS * param,int flags)611 PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
612 {
613 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
614 SV *arg;
615 PERL_UNUSED_ARG(flags);
616
617 /* During cloning, return an undef token object so that _pushed() knows
618 * that it should not call methods and wait for _dup() to actually dup the
619 * object. */
620 if (param) {
621 SV *sv = newSV(0);
622 sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOVia_tag, 0, 0);
623 return sv;
624 }
625
626 arg = PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
627 if (arg) {
628 /* arg is a temp, and PerlIOBase_dup() will explicitly free it */
629 SvREFCNT_inc(arg);
630 }
631 else {
632 arg = newSVpvn(HvNAME(s->stash), HvNAMELEN(s->stash));
633 }
634
635 return arg;
636 }
637
638 static PerlIO *
PerlIOVia_dup(pTHX_ PerlIO * f,PerlIO * o,CLONE_PARAMS * param,int flags)639 PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
640 int flags)
641 {
642 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
643 #ifdef USE_ITHREADS
644 if (param) {
645 /* For a non-interpreter dup stash and obj have been set up
646 by the implied push.
647
648 But if this is a clone for a new interpreter we need to
649 translate the objects to their dups.
650 */
651
652 PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
653 PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
654
655 fs->obj = sv_dup_inc(os->obj, param);
656 fs->stash = (HV*)sv_dup((SV*)os->stash, param);
657 fs->var = sv_dup_inc(os->var, param);
658 fs->cnt = os->cnt;
659
660 /* fh, io, cached CVs left as NULL, PerlIOVia_method()
661 will reinitialize them if needed */
662 }
663 #endif
664 /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
665 }
666
667 return f;
668 }
669
670
671
672 static PERLIO_FUNCS_DECL(PerlIO_object) = {
673 sizeof(PerlIO_funcs),
674 "via",
675 sizeof(PerlIOVia),
676 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
677 PerlIOVia_pushed,
678 PerlIOVia_popped,
679 PerlIOVia_open, /* NULL, */
680 PerlIOVia_binmode, /* NULL, */
681 PerlIOVia_getarg,
682 PerlIOVia_fileno,
683 PerlIOVia_dup,
684 PerlIOVia_read,
685 PerlIOVia_unread,
686 PerlIOVia_write,
687 PerlIOVia_seek,
688 PerlIOVia_tell,
689 PerlIOVia_close,
690 PerlIOVia_flush,
691 PerlIOVia_fill,
692 PerlIOVia_eof,
693 PerlIOVia_error,
694 PerlIOVia_clearerr,
695 PerlIOVia_setlinebuf,
696 PerlIOVia_get_base,
697 PerlIOVia_bufsiz,
698 PerlIOVia_get_ptr,
699 PerlIOVia_get_cnt,
700 PerlIOVia_set_ptrcnt,
701 };
702
703
704 #endif /* Layers available */
705
706 MODULE = PerlIO::via PACKAGE = PerlIO::via
707 PROTOTYPES: ENABLE;
708
709 BOOT:
710 {
711 #ifdef PERLIO_LAYERS
712 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_object));
713 #endif
714 }
715
716
717
718
719
720