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