source: trunk/essentials/dev-lang/perl/ext/PerlIO/via/via.xs@ 3212

Last change on this file since 3212 was 3181, checked in by bird, 19 years ago

perl 5.8.8
File size: 13.9 KB
Line 
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;
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
43CV *
44PerlIOVia_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
66SV *
67PerlIOVia_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
120IV
121PerlIOVia_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);
188push_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
203PerlIO *
204PerlIOVia_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
298IV
299PerlIOVia_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
324IV
325PerlIOVia_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
337IV
338PerlIOVia_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
346IV
347PerlIOVia_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
359IV
360PerlIOVia_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
379Off_t
380PerlIOVia_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
390SSize_t
391PerlIOVia_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
404SSize_t
405PerlIOVia_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
429SSize_t
430PerlIOVia_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
446IV
447PerlIOVia_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
470IV
471PerlIOVia_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
483STDCHAR *
484PerlIOVia_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
495STDCHAR *
496PerlIOVia_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
508SSize_t
509PerlIOVia_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
520Size_t
521PerlIOVia_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
531void
532PerlIOVia_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
533{
534 PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
535 s->cnt = cnt;
536}
537
538void
539PerlIOVia_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
546void
547PerlIOVia_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
554IV
555PerlIOVia_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
563IV
564PerlIOVia_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
572SV *
573PerlIOVia_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
579PerlIO *
580PerlIOVia_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
593PerlIO_funcs 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
627MODULE = PerlIO::via PACKAGE = PerlIO::via
628PROTOTYPES: ENABLE;
629
630BOOT:
631{
632#ifdef PERLIO_LAYERS
633 PerlIO_define_layer(aTHX_ &PerlIO_object);
634#endif
635}
636
637
638
639
640
Note: See TracBrowser for help on using the repository browser.