This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perldiag patch for implied open of STDIN/STDOUT/STDERR
[perl5.git] / ext / PerlIO / Via / Via.xs
CommitLineData
e7a1fdd7
NIS
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
9typedef struct
10{
11 struct _PerlIO base; /* Base "class" info */
12 HV * stash;
13 SV * obj;
14 SV * var;
15 SSize_t cnt;
e7a1fdd7
NIS
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;
c7997937 35 CV *mERROR;
e7a1fdd7 36 CV *mEOF;
86e05cf2 37 CV *BINMODE;
e7a1fdd7
NIS
38} PerlIOVia;
39
40#define MYMethod(x) #x,&s->x
41
42CV *
43PerlIOVia_fetchmethod(pTHX_ PerlIOVia *s,char *method,CV **save)
44{
45 GV *gv = gv_fetchmeth(s->stash,method,strlen(method),0);
46#if 0
47 Perl_warn(aTHX_ "Lookup %s::%s => %p",HvNAME(s->stash),method,gv);
48#endif
49 if (gv)
50 {
51 return *save = GvCV(gv);
52 }
53 else
54 {
55 return *save = (CV *) -1;
56 }
e7a1fdd7
NIS
57}
58
d9dac8cd
NIS
59/*
60 * Try and call method, possibly via cached lookup.
61 * If method does not exist return Nullsv (caller may fallback to another approach
62 * If method does exist call it with flags passing variable number of args
63 * Last arg is a "filehandle" to layer below (if present)
64 * Returns scalar returned by method (if any) otherwise sv_undef
65 */
66
e7a1fdd7
NIS
67SV *
68PerlIOVia_method(pTHX_ PerlIO *f,char *method,CV **save,int flags,...)
69{
70 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
71 CV *cv = (*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s,method,save);
72 SV *result = Nullsv;
73 va_list ap;
74 va_start(ap,flags);
75 if (cv != (CV *)-1)
76 {
77 IV count;
78 dSP;
79 SV *arg;
24f59afc 80 PUSHSTACKi(PERLSI_MAGIC);
e7a1fdd7 81 ENTER;
24f59afc 82 SPAGAIN;
e7a1fdd7
NIS
83 PUSHMARK(sp);
84 XPUSHs(s->obj);
85 while ((arg = va_arg(ap,SV *)))
86 {
87 XPUSHs(arg);
88 }
89 if (*PerlIONext(f))
90 {
91 if (!s->fh)
92 {
93 GV *gv = newGVgen(HvNAME(s->stash));
94 GvIOp(gv) = newIO();
95 s->fh = newRV_noinc((SV *)gv);
96 s->io = GvIOp(gv);
97 }
98 IoIFP(s->io) = PerlIONext(f);
99 IoOFP(s->io) = PerlIONext(f);
100 XPUSHs(s->fh);
101 }
d9dac8cd
NIS
102 else
103 {
104 PerlIO_debug("No next\n");
105 }
e7a1fdd7
NIS
106 PUTBACK;
107 count = call_sv((SV *)cv,flags);
108 if (count)
109 {
110 SPAGAIN;
111 result = POPs;
112 PUTBACK;
113 }
114 else
115 {
116 result = &PL_sv_undef;
117 }
118 LEAVE;
24f59afc 119 POPSTACK;
e7a1fdd7
NIS
120 }
121 va_end(ap);
122 return result;
123}
124
125IV
2dc2558e 126PerlIOVia_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
e7a1fdd7 127{
2dc2558e 128 IV code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv,tab);
e7a1fdd7
NIS
129 if (code == 0)
130 {
e7a1fdd7
NIS
131 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
132 if (!arg)
133 {
99ef548b
PM
134 if (ckWARN(WARN_LAYER))
135 Perl_warner(aTHX_ packWARN(WARN_LAYER), "No package specified");
d9dac8cd 136 errno = EINVAL;
e7a1fdd7
NIS
137 code = -1;
138 }
139 else
140 {
141 STRLEN pkglen = 0;
142 char *pkg = SvPV(arg,pkglen);
267cbce7 143 s->obj = SvREFCNT_inc(arg);
e7a1fdd7 144 s->stash = gv_stashpvn(pkg, pkglen, FALSE);
52f3c1af
RGS
145 if (!s->stash)
146 {
147 s->obj = newSVpvn(Perl_form(aTHX_ "PerlIO::Via::%s",pkg), pkglen + 13);
148 SvREFCNT_dec(arg);
149 s->stash = gv_stashpvn(SvPVX(s->obj), pkglen + 13, FALSE);
150 }
e7a1fdd7
NIS
151 if (s->stash)
152 {
153 SV *modesv = (mode) ? sv_2mortal(newSVpvn(mode,strlen(mode))) : Nullsv;
154 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(PUSHED),G_SCALAR,modesv,Nullsv);
155 if (result)
156 {
157 if (sv_isobject(result))
267cbce7
NIS
158 {
159 s->obj = SvREFCNT_inc(result);
160 SvREFCNT_dec(arg);
161 }
e7a1fdd7
NIS
162 else if (SvIV(result) != 0)
163 return SvIV(result);
164 }
165 if (PerlIOVia_fetchmethod(aTHX_ s,MYMethod(FILL)) == (CV *) -1)
166 PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
167 else
168 PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
169 }
170 else
171 {
99ef548b
PM
172 if (ckWARN(WARN_LAYER))
173 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Cannot find package '%.*s'",(int) pkglen,pkg);
267cbce7
NIS
174#ifdef ENOSYS
175 errno = ENOSYS;
176#else
177#ifdef ENOENT
178 errno = ENOENT;
179#endif
180#endif
e7a1fdd7
NIS
181 code = -1;
182 }
183 }
184 }
185 return code;
186}
187
188PerlIO *
d9dac8cd
NIS
189PerlIOVia_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n,
190 const char *mode, int fd, int imode, int perm,
191 PerlIO *f, int narg, SV **args)
e7a1fdd7
NIS
192{
193 if (!f)
194 {
195 f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX),self,mode,PerlIOArg);
196 }
197 else
198 {
d9dac8cd 199 /* Reopen */
e7a1fdd7
NIS
200 if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
201 return NULL;
202 }
203 if (f)
204 {
205 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
206 SV *result = Nullsv;
207 if (fd >= 0)
208 {
209 SV *fdsv = sv_2mortal(newSViv(fd));
210 result = PerlIOVia_method(aTHX_ f,MYMethod(FDOPEN),G_SCALAR,fdsv,Nullsv);
211 }
212 else if (narg > 0)
213 {
214 if (*mode == '#')
215 {
216 SV *imodesv = sv_2mortal(newSViv(imode));
217 SV *permsv = sv_2mortal(newSViv(perm));
218 result = PerlIOVia_method(aTHX_ f,MYMethod(SYSOPEN),G_SCALAR,*args,imodesv,permsv,Nullsv);
219 }
220 else
221 {
222 result = PerlIOVia_method(aTHX_ f,MYMethod(OPEN),G_SCALAR,*args,Nullsv);
223 }
224 }
225 if (result)
226 {
227 if (sv_isobject(result))
228 s->obj = SvREFCNT_inc(result);
229 else if (!SvTRUE(result))
230 {
231 return NULL;
232 }
233 }
234 else
d9dac8cd
NIS
235 {
236 /* Required open method not present */
237 PerlIO_funcs *tab = NULL;
238 IV m = n-1;
239 while (m >= 0) {
240 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layers, m, NULL);
241 if (t && t->Open) {
242 tab = t;
243 break;
244 }
245 n--;
246 }
247 if (tab) {
248 if ((*tab->Open) (aTHX_ tab, layers, m, mode, fd, imode, perm,
249 PerlIONext(f), narg, args)) {
250 PerlIO_debug("Opened with %s => %p->%p\n",tab->name,PerlIONext(f),*PerlIONext(f));
251 if (m + 1 < n) {
252 /*
253 * More layers above the one that we used to open -
254 * apply them now
255 */
256 if (PerlIO_apply_layera(aTHX_ PerlIONext(f), mode, layers, m+1, n) != 0) {
257 /* If pushing layers fails close the file */
258 PerlIO_close(f);
259 f = NULL;
260 }
261 }
262 return f;
263 }
264 else {
265 /* Sub-layer open failed */
266 }
267 }
268 else {
269 /* Nothing to do the open */
270 }
271 return NULL;
272 }
e7a1fdd7
NIS
273 }
274 return f;
275}
276
277IV
f62ce20a 278PerlIOVia_popped(pTHX_ PerlIO *f)
e7a1fdd7 279{
e7a1fdd7
NIS
280 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
281 PerlIOVia_method(aTHX_ f,MYMethod(POPPED),G_VOID,Nullsv);
282 if (s->var)
283 {
284 SvREFCNT_dec(s->var);
285 s->var = Nullsv;
286 }
287
288 if (s->io)
289 {
290 IoIFP(s->io) = NULL;
291 IoOFP(s->io) = NULL;
292 }
293 if (s->fh)
294 {
295 SvREFCNT_dec(s->fh);
296 s->fh = Nullsv;
297 s->io = NULL;
298 }
299 if (s->obj)
300 {
301 SvREFCNT_dec(s->obj);
302 s->obj = Nullsv;
303 }
304 return 0;
305}
306
307IV
f62ce20a 308PerlIOVia_close(pTHX_ PerlIO *f)
e7a1fdd7 309{
e7a1fdd7 310 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
f62ce20a 311 IV code = PerlIOBase_close(aTHX_ f);
e7a1fdd7
NIS
312 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(CLOSE),G_SCALAR,Nullsv);
313 if (result && SvIV(result) != 0)
314 code = SvIV(result);
315 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
316 return code;
317}
318
319IV
f62ce20a 320PerlIOVia_fileno(pTHX_ PerlIO *f)
e7a1fdd7 321{
e7a1fdd7
NIS
322 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
323 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILENO),G_SCALAR,Nullsv);
324 return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
325}
326
327IV
86e05cf2
NIS
328PerlIOVia_binmode(pTHX_ PerlIO *f)
329{
330 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
331 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(BINMODE),G_SCALAR,Nullsv);
332 if (!result || !SvOK(result))
333 {
334 PerlIO_pop(aTHX_ f);
335 return 0;
336 }
337 return SvIV(result);
338}
339
340IV
f62ce20a 341PerlIOVia_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
e7a1fdd7 342{
e7a1fdd7
NIS
343 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
344 SV *offsv = sv_2mortal(newSViv(offset));
9f16d962 345 SV *whsv = sv_2mortal(newSViv(whence));
e7a1fdd7
NIS
346 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
347 return (result) ? SvIV(result) : -1;
348}
349
350Off_t
f62ce20a 351PerlIOVia_tell(pTHX_ PerlIO *f)
e7a1fdd7 352{
e7a1fdd7
NIS
353 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
354 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
9f16d962 355 return (result) ? (Off_t) SvIV(result) : (Off_t) -1;
e7a1fdd7
NIS
356}
357
358SSize_t
f62ce20a 359PerlIOVia_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
e7a1fdd7 360{
e7a1fdd7
NIS
361 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
362 SV *buf = sv_2mortal(newSVpvn((char *)vbuf,count));
363 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(UNREAD),G_SCALAR,buf,Nullsv);
364 if (result)
365 return (SSize_t) SvIV(result);
366 else
367 {
f62ce20a 368 return PerlIOBase_unread(aTHX_ f,vbuf,count);
e7a1fdd7
NIS
369 }
370}
371
372SSize_t
f62ce20a 373PerlIOVia_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
e7a1fdd7
NIS
374{
375 SSize_t rd = 0;
376 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
377 {
378 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)
379 {
f62ce20a 380 rd = PerlIOBase_read(aTHX_ f,vbuf,count);
e7a1fdd7
NIS
381 }
382 else
383 {
e7a1fdd7
NIS
384 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
385 SV *buf = sv_2mortal(newSV(count));
386 SV *n = sv_2mortal(newSViv(count));
387 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(READ),G_SCALAR,buf,n,Nullsv);
388 if (result)
389 {
390 rd = (SSize_t) SvIV(result);
391 Move(SvPVX(buf),vbuf,rd,char);
392 return rd;
393 }
394 }
395 }
396 return rd;
397}
398
399SSize_t
f62ce20a 400PerlIOVia_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
e7a1fdd7
NIS
401{
402 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
403 {
e7a1fdd7
NIS
404 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
405 SV *buf = newSVpvn((char *)vbuf,count);
406 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(WRITE),G_SCALAR,buf,Nullsv);
407 SvREFCNT_dec(buf);
408 if (result)
409 return (SSize_t) SvIV(result);
410 return -1;
411 }
412 return 0;
413}
414
415IV
f62ce20a 416PerlIOVia_fill(pTHX_ PerlIO *f)
e7a1fdd7
NIS
417{
418 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
419 {
e7a1fdd7
NIS
420 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
421 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILL),G_SCALAR,Nullsv);
422 if (s->var)
423 {
424 SvREFCNT_dec(s->var);
425 s->var = Nullsv;
426 }
427 if (result && SvOK(result))
428 {
429 STRLEN len = 0;
430 char *p = SvPV(result,len);
431 s->var = newSVpvn(p,len);
432 s->cnt = SvCUR(s->var);
433 return 0;
434 }
435 else
436 PerlIOBase(f)->flags |= PERLIO_F_EOF;
437 }
438 return -1;
439}
440
441IV
f62ce20a 442PerlIOVia_flush(pTHX_ PerlIO *f)
e7a1fdd7 443{
e7a1fdd7
NIS
444 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
445 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FLUSH),G_SCALAR,Nullsv);
446 if (s->var && s->cnt > 0)
447 {
448 SvREFCNT_dec(s->var);
449 s->var = Nullsv;
450 }
451 return (result) ? SvIV(result) : 0;
452}
453
454STDCHAR *
f62ce20a 455PerlIOVia_get_base(pTHX_ PerlIO *f)
e7a1fdd7
NIS
456{
457 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
458 {
e7a1fdd7
NIS
459 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
460 if (s->var)
461 {
462 return (STDCHAR *)SvPVX(s->var);
463 }
464 }
465 return (STDCHAR *) Nullch;
466}
467
468STDCHAR *
f62ce20a 469PerlIOVia_get_ptr(pTHX_ PerlIO *f)
e7a1fdd7
NIS
470{
471 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
472 {
473 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
474 if (s->var)
475 {
e7a1fdd7
NIS
476 STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
477 return p;
478 }
479 }
480 return (STDCHAR *) Nullch;
481}
482
483SSize_t
f62ce20a 484PerlIOVia_get_cnt(pTHX_ PerlIO *f)
e7a1fdd7
NIS
485{
486 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
487 {
488 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
489 if (s->var)
490 {
491 return s->cnt;
492 }
493 }
494 return 0;
495}
496
497Size_t
f62ce20a 498PerlIOVia_bufsiz(pTHX_ PerlIO *f)
e7a1fdd7
NIS
499{
500 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
501 {
502 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
503 if (s->var)
504 return SvCUR(s->var);
505 }
506 return 0;
507}
508
509void
f62ce20a 510PerlIOVia_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR *ptr, SSize_t cnt)
e7a1fdd7
NIS
511{
512 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
513 s->cnt = cnt;
514}
515
516void
f62ce20a 517PerlIOVia_setlinebuf(pTHX_ PerlIO *f)
e7a1fdd7 518{
e7a1fdd7
NIS
519 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
520 PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
f62ce20a 521 PerlIOBase_setlinebuf(aTHX_ f);
e7a1fdd7
NIS
522}
523
524void
f62ce20a 525PerlIOVia_clearerr(pTHX_ PerlIO *f)
e7a1fdd7 526{
e7a1fdd7
NIS
527 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
528 PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
f62ce20a 529 PerlIOBase_clearerr(aTHX_ f);
e7a1fdd7
NIS
530}
531
c7997937 532IV
f62ce20a 533PerlIOVia_error(pTHX_ PerlIO *f)
e7a1fdd7 534{
e7a1fdd7 535 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
c7997937 536 SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
f62ce20a 537 return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
e7a1fdd7
NIS
538}
539
540IV
f62ce20a 541PerlIOVia_eof(pTHX_ PerlIO *f)
e7a1fdd7 542{
e7a1fdd7
NIS
543 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
544 SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
f62ce20a 545 return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
e7a1fdd7
NIS
546}
547
ecdeb87c
NIS
548SV *
549PerlIOVia_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
550{
551 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
552 return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
553}
554
8cf8f3d1 555PerlIO *
ecdeb87c 556PerlIOVia_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
8cf8f3d1 557{
ecdeb87c 558 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)))
9f16d962 559 {
ecdeb87c 560 /* Most of the fields will lazily set themselves up as needed
9f16d962
NIS
561 stash and obj have been set up by the implied push
562 */
563 }
564 return f;
8cf8f3d1
NIS
565}
566
e7a1fdd7 567PerlIO_funcs PerlIO_object = {
2dc2558e 568 sizeof(PerlIO_funcs),
e7a1fdd7
NIS
569 "Via",
570 sizeof(PerlIOVia),
571 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
572 PerlIOVia_pushed,
573 PerlIOVia_popped,
d9dac8cd 574 PerlIOVia_open, /* NULL, */
86e05cf2 575 PerlIOVia_binmode, /* NULL, */
e7a1fdd7
NIS
576 PerlIOVia_getarg,
577 PerlIOVia_fileno,
8cf8f3d1 578 PerlIOVia_dup,
e7a1fdd7
NIS
579 PerlIOVia_read,
580 PerlIOVia_unread,
581 PerlIOVia_write,
582 PerlIOVia_seek,
583 PerlIOVia_tell,
584 PerlIOVia_close,
585 PerlIOVia_flush,
586 PerlIOVia_fill,
587 PerlIOVia_eof,
588 PerlIOVia_error,
589 PerlIOVia_clearerr,
590 PerlIOVia_setlinebuf,
591 PerlIOVia_get_base,
592 PerlIOVia_bufsiz,
593 PerlIOVia_get_ptr,
594 PerlIOVia_get_cnt,
595 PerlIOVia_set_ptrcnt,
596};
597
598
599#endif /* Layers available */
600
601MODULE = PerlIO::Via PACKAGE = PerlIO::Via
602PROTOTYPES: ENABLE;
603
604BOOT:
605{
606#ifdef PERLIO_LAYERS
607 PerlIO_define_layer(aTHX_ &PerlIO_object);
608#endif
609}
610