This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change PerlIO::Scalar and Via to scalar and via.
[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                 SV *modesv =
147                     (mode) ? sv_2mortal(newSVpvn(mode, strlen(mode))) :
148                     Nullsv;
149                 SV *result =
150                     PerlIOVia_method(aTHX_ f, MYMethod(PUSHED), G_SCALAR,
151                                      modesv, Nullsv);
152                 if (result) {
153                     if (sv_isobject(result)) {
154                         s->obj = SvREFCNT_inc(result);
155                         SvREFCNT_dec(arg);
156                     }
157                     else if (SvIV(result) != 0)
158                         return SvIV(result);
159                 }
160                 if (PerlIOVia_fetchmethod(aTHX_ s, MYMethod(FILL)) ==
161                     (CV *) - 1)
162                     PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
163                 else
164                     PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
165             }
166             else {
167                 if (ckWARN(WARN_LAYER))
168                     Perl_warner(aTHX_ packWARN(WARN_LAYER),
169                                 "Cannot find package '%.*s'", (int) pkglen,
170                                 pkg);
171 #ifdef ENOSYS
172                 errno = ENOSYS;
173 #else
174 #ifdef ENOENT
175                 errno = ENOENT;
176 #endif
177 #endif
178                 code = -1;
179             }
180         }
181     }
182     return code;
183 }
184
185 PerlIO *
186 PerlIOVia_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers,
187                IV n, const char *mode, int fd, int imode, int perm,
188                PerlIO * f, int narg, SV ** args)
189 {
190     if (!f) {
191         f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX), self, mode,
192                         PerlIOArg);
193     }
194     else {
195         /* Reopen */
196         if (!PerlIO_push(aTHX_ f, self, mode, PerlIOArg))
197             return NULL;
198     }
199     if (f) {
200         PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
201         SV *result = Nullsv;
202         if (fd >= 0) {
203             SV *fdsv = sv_2mortal(newSViv(fd));
204             result =
205                 PerlIOVia_method(aTHX_ f, MYMethod(FDOPEN), G_SCALAR, fdsv,
206                                  Nullsv);
207         }
208         else if (narg > 0) {
209             if (*mode == '#') {
210                 SV *imodesv = sv_2mortal(newSViv(imode));
211                 SV *permsv = sv_2mortal(newSViv(perm));
212                 result =
213                     PerlIOVia_method(aTHX_ f, MYMethod(SYSOPEN), G_SCALAR,
214                                      *args, imodesv, permsv, Nullsv);
215             }
216             else {
217                 result =
218                     PerlIOVia_method(aTHX_ f, MYMethod(OPEN), G_SCALAR,
219                                      *args, Nullsv);
220             }
221         }
222         if (result) {
223             if (sv_isobject(result))
224                 s->obj = SvREFCNT_inc(result);
225             else if (!SvTRUE(result)) {
226                 return NULL;
227             }
228         }
229         else {
230             /* Required open method not present */
231             PerlIO_funcs *tab = NULL;
232             IV m = n - 1;
233             while (m >= 0) {
234                 PerlIO_funcs *t =
235                     PerlIO_layer_fetch(aTHX_ layers, m, NULL);
236                 if (t && t->Open) {
237                     tab = t;
238                     break;
239                 }
240                 n--;
241             }
242             if (tab) {
243                 if ((*tab->Open) (aTHX_ tab, layers, m, mode, fd, imode,
244                                   perm, PerlIONext(f), narg, args)) {
245                     PerlIO_debug("Opened with %s => %p->%p\n", tab->name,
246                                  PerlIONext(f), *PerlIONext(f));
247                     if (m + 1 < n) {
248                         /*
249                          * More layers above the one that we used to open -
250                          * apply them now
251                          */
252                         if (PerlIO_apply_layera
253                             (aTHX_ PerlIONext(f), mode, layers, m + 1,
254                              n) != 0) {
255                             /* If pushing layers fails close the file */
256                             PerlIO_close(f);
257                             f = NULL;
258                         }
259                     }
260                     /* FIXME - Call an OPENED method here ? */
261                     return f;
262                 }
263                 else {
264                     PerlIO_debug("Open fail %s => %p->%p\n", tab->name,
265                                  PerlIONext(f), *PerlIONext(f));
266                     /* Sub-layer open failed */
267                 }
268             }
269             else {
270                  PerlIO_debug("Nothing to open with");
271                 /* Nothing to do the open */
272             }
273             PerlIO_pop(aTHX_ f);
274             return NULL;
275         }
276     }
277     return f;
278 }
279
280 IV
281 PerlIOVia_popped(pTHX_ PerlIO * f)
282 {
283     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
284     PerlIOVia_method(aTHX_ f, MYMethod(POPPED), G_VOID, Nullsv);
285     if (s->var) {
286         SvREFCNT_dec(s->var);
287         s->var = Nullsv;
288     }
289
290     if (s->io) {
291         IoIFP(s->io) = NULL;
292         IoOFP(s->io) = NULL;
293     }
294     if (s->fh) {
295         SvREFCNT_dec(s->fh);
296         s->fh = Nullsv;
297         s->io = NULL;
298     }
299     if (s->obj) {
300         SvREFCNT_dec(s->obj);
301         s->obj = Nullsv;
302     }
303     return 0;
304 }
305
306 IV
307 PerlIOVia_close(pTHX_ PerlIO * f)
308 {
309     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
310     IV code = PerlIOBase_close(aTHX_ f);
311     SV *result =
312         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
319 IV
320 PerlIOVia_fileno(pTHX_ PerlIO * f)
321 {
322     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
323     SV *result =
324         PerlIOVia_method(aTHX_ f, MYMethod(FILENO), G_SCALAR, Nullsv);
325     return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
326 }
327
328 IV
329 PerlIOVia_binmode(pTHX_ PerlIO * f)
330 {
331     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
332     SV *result =
333         PerlIOVia_method(aTHX_ f, MYMethod(BINMODE), G_SCALAR, Nullsv);
334     if (!result || !SvOK(result)) {
335         PerlIO_pop(aTHX_ f);
336         return 0;
337     }
338     return SvIV(result);
339 }
340
341 IV
342 PerlIOVia_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
343 {
344     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
345     SV *offsv = sv_2mortal(newSViv(offset));
346     SV *whsv = sv_2mortal(newSViv(whence));
347     SV *result =
348         PerlIOVia_method(aTHX_ f, MYMethod(SEEK), G_SCALAR, offsv, whsv,
349                          Nullsv);
350     return (result) ? SvIV(result) : -1;
351 }
352
353 Off_t
354 PerlIOVia_tell(pTHX_ PerlIO * f)
355 {
356     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
357     SV *result =
358         PerlIOVia_method(aTHX_ f, MYMethod(TELL), G_SCALAR, Nullsv);
359     return (result) ? (Off_t) SvIV(result) : (Off_t) - 1;
360 }
361
362 SSize_t
363 PerlIOVia_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
364 {
365     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
366     SV *buf = sv_2mortal(newSVpvn((char *) vbuf, count));
367     SV *result =
368         PerlIOVia_method(aTHX_ f, MYMethod(UNREAD), G_SCALAR, buf, Nullsv);
369     if (result)
370         return (SSize_t) SvIV(result);
371     else {
372         return PerlIOBase_unread(aTHX_ f, vbuf, count);
373     }
374 }
375
376 SSize_t
377 PerlIOVia_read(pTHX_ PerlIO * f, void *vbuf, Size_t count)
378 {
379     SSize_t rd = 0;
380     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
381         if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
382             rd = PerlIOBase_read(aTHX_ f, vbuf, count);
383         }
384         else {
385             PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
386             SV *buf = sv_2mortal(newSV(count));
387             SV *n = sv_2mortal(newSViv(count));
388             SV *result =
389                 PerlIOVia_method(aTHX_ f, MYMethod(READ), G_SCALAR, buf, n,
390                                  Nullsv);
391             if (result) {
392                 rd = (SSize_t) SvIV(result);
393                 Move(SvPVX(buf), vbuf, rd, char);
394                 return rd;
395             }
396         }
397     }
398     return rd;
399 }
400
401 SSize_t
402 PerlIOVia_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
403 {
404     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
405         PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
406         SV *buf = newSVpvn((char *) vbuf, count);
407         SV *result =
408             PerlIOVia_method(aTHX_ f, MYMethod(WRITE), G_SCALAR, buf,
409                              Nullsv);
410         SvREFCNT_dec(buf);
411         if (result)
412             return (SSize_t) SvIV(result);
413         return -1;
414     }
415     return 0;
416 }
417
418 IV
419 PerlIOVia_fill(pTHX_ PerlIO * f)
420 {
421     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
422         PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
423         SV *result =
424             PerlIOVia_method(aTHX_ f, MYMethod(FILL), G_SCALAR, Nullsv);
425         if (s->var) {
426             SvREFCNT_dec(s->var);
427             s->var = Nullsv;
428         }
429         if (result && SvOK(result)) {
430             STRLEN len = 0;
431             char *p = SvPV(result, len);
432             s->var = newSVpvn(p, len);
433             s->cnt = SvCUR(s->var);
434             return 0;
435         }
436         else
437             PerlIOBase(f)->flags |= PERLIO_F_EOF;
438     }
439     return -1;
440 }
441
442 IV
443 PerlIOVia_flush(pTHX_ PerlIO * f)
444 {
445     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
446     SV *result =
447         PerlIOVia_method(aTHX_ f, MYMethod(FLUSH), G_SCALAR, Nullsv);
448     if (s->var && s->cnt > 0) {
449         SvREFCNT_dec(s->var);
450         s->var = Nullsv;
451     }
452     return (result) ? SvIV(result) : 0;
453 }
454
455 STDCHAR *
456 PerlIOVia_get_base(pTHX_ PerlIO * f)
457 {
458     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
459         PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
460         if (s->var) {
461             return (STDCHAR *) SvPVX(s->var);
462         }
463     }
464     return (STDCHAR *) Nullch;
465 }
466
467 STDCHAR *
468 PerlIOVia_get_ptr(pTHX_ PerlIO * f)
469 {
470     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
471         PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
472         if (s->var) {
473             STDCHAR *p = (STDCHAR *) (SvEND(s->var) - s->cnt);
474             return p;
475         }
476     }
477     return (STDCHAR *) Nullch;
478 }
479
480 SSize_t
481 PerlIOVia_get_cnt(pTHX_ PerlIO * f)
482 {
483     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
484         PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
485         if (s->var) {
486             return s->cnt;
487         }
488     }
489     return 0;
490 }
491
492 Size_t
493 PerlIOVia_bufsiz(pTHX_ PerlIO * f)
494 {
495     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
496         PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
497         if (s->var)
498             return SvCUR(s->var);
499     }
500     return 0;
501 }
502
503 void
504 PerlIOVia_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
505 {
506     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
507     s->cnt = cnt;
508 }
509
510 void
511 PerlIOVia_setlinebuf(pTHX_ PerlIO * f)
512 {
513     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
514     PerlIOVia_method(aTHX_ f, MYMethod(SETLINEBUF), G_VOID, Nullsv);
515     PerlIOBase_setlinebuf(aTHX_ f);
516 }
517
518 void
519 PerlIOVia_clearerr(pTHX_ PerlIO * f)
520 {
521     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
522     PerlIOVia_method(aTHX_ f, MYMethod(CLEARERR), G_VOID, Nullsv);
523     PerlIOBase_clearerr(aTHX_ f);
524 }
525
526 IV
527 PerlIOVia_error(pTHX_ PerlIO * f)
528 {
529     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
530     SV *result =
531         PerlIOVia_method(aTHX_ f, "ERROR", &s->mERROR, G_SCALAR, Nullsv);
532     return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
533 }
534
535 IV
536 PerlIOVia_eof(pTHX_ PerlIO * f)
537 {
538     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
539     SV *result =
540         PerlIOVia_method(aTHX_ f, "EOF", &s->mEOF, G_SCALAR, Nullsv);
541     return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
542 }
543
544 SV *
545 PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
546 {
547     PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
548     return PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
549 }
550
551 PerlIO *
552 PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
553               int flags)
554 {
555     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
556         /* Most of the fields will lazily set themselves up as needed
557            stash and obj have been set up by the implied push
558          */
559     }
560     return f;
561 }
562
563
564
565 PerlIO_funcs PerlIO_object = {
566  sizeof(PerlIO_funcs),
567  "via",
568  sizeof(PerlIOVia),
569  PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
570  PerlIOVia_pushed,
571  PerlIOVia_popped,
572  PerlIOVia_open, /* NULL, */
573  PerlIOVia_binmode, /* NULL, */
574  PerlIOVia_getarg,
575  PerlIOVia_fileno,
576  PerlIOVia_dup,
577  PerlIOVia_read,
578  PerlIOVia_unread,
579  PerlIOVia_write,
580  PerlIOVia_seek,
581  PerlIOVia_tell,
582  PerlIOVia_close,
583  PerlIOVia_flush,
584  PerlIOVia_fill,
585  PerlIOVia_eof,
586  PerlIOVia_error,
587  PerlIOVia_clearerr,
588  PerlIOVia_setlinebuf,
589  PerlIOVia_get_base,
590  PerlIOVia_bufsiz,
591  PerlIOVia_get_ptr,
592  PerlIOVia_get_cnt,
593  PerlIOVia_set_ptrcnt,
594 };
595
596
597 #endif /* Layers available */
598
599 MODULE = PerlIO::via    PACKAGE = PerlIO::via
600 PROTOTYPES: ENABLE;
601
602 BOOT:
603 {
604 #ifdef PERLIO_LAYERS
605  PerlIO_define_layer(aTHX_ &PerlIO_object);
606 #endif
607 }
608
609
610
611
612