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