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