This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PerlIO::Via layer (alpha-ish).
[perl5.git] / ext / PerlIO / Via / Via.xs
CommitLineData
e7a1fdd7
NIS
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 Off_t posn;
17 IO * io;
18 SV * fh;
19 CV *PUSHED;
20 CV *POPPED;
21 CV *OPEN;
22 CV *FDOPEN;
23 CV *SYSOPEN;
24 CV *GETARG;
25 CV *FILENO;
26 CV *READ;
27 CV *WRITE;
28 CV *FILL;
29 CV *CLOSE;
30 CV *SEEK;
31 CV *TELL;
32 CV *UNREAD;
33 CV *FLUSH;
34 CV *SETLINEBUF;
35 CV *CLEARERR;
36 CV *ERROR;
37 CV *mEOF;
38} PerlIOVia;
39
40#define MYMethod(x) #x,&s->x
41
42CV *
43PerlIOVia_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 {
51 return *save = GvCV(gv);
52 }
53 else
54 {
55 return *save = (CV *) -1;
56 }
57
58}
59
60SV *
61PerlIOVia_method(pTHX_ PerlIO *f,char *method,CV **save,int flags,...)
62{
63 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
64 CV *cv = (*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s,method,save);
65 SV *result = Nullsv;
66 va_list ap;
67 va_start(ap,flags);
68 if (cv != (CV *)-1)
69 {
70 IV count;
71 dSP;
72 SV *arg;
73 int i = 0;
74 ENTER;
75 PUSHMARK(sp);
76 XPUSHs(s->obj);
77 while ((arg = va_arg(ap,SV *)))
78 {
79 XPUSHs(arg);
80 }
81 if (*PerlIONext(f))
82 {
83 if (!s->fh)
84 {
85 GV *gv = newGVgen(HvNAME(s->stash));
86 GvIOp(gv) = newIO();
87 s->fh = newRV_noinc((SV *)gv);
88 s->io = GvIOp(gv);
89 }
90 IoIFP(s->io) = PerlIONext(f);
91 IoOFP(s->io) = PerlIONext(f);
92 XPUSHs(s->fh);
93 }
94 PUTBACK;
95 count = call_sv((SV *)cv,flags);
96 if (count)
97 {
98 SPAGAIN;
99 result = POPs;
100 PUTBACK;
101 }
102 else
103 {
104 result = &PL_sv_undef;
105 }
106 LEAVE;
107 }
108 va_end(ap);
109 return result;
110}
111
112IV
113PerlIOVia_pushed(PerlIO *f, const char *mode, SV *arg)
114{
115 IV code = PerlIOBase_pushed(f,mode,Nullsv);
116 if (code == 0)
117 {
118 dTHX;
119 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
120 if (!arg)
121 {
122 Perl_warn(aTHX_ "No package specified");
123 code = -1;
124 }
125 else
126 {
127 STRLEN pkglen = 0;
128 char *pkg = SvPV(arg,pkglen);
129 s->obj = arg;
130 s->stash = gv_stashpvn(pkg, pkglen, FALSE);
131 if (s->stash)
132 {
133 SV *modesv = (mode) ? sv_2mortal(newSVpvn(mode,strlen(mode))) : Nullsv;
134 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(PUSHED),G_SCALAR,modesv,Nullsv);
135 if (result)
136 {
137 if (sv_isobject(result))
138 s->obj = SvREFCNT_inc(result);
139 else if (SvIV(result) != 0)
140 return SvIV(result);
141 }
142 if (PerlIOVia_fetchmethod(aTHX_ s,MYMethod(FILL)) == (CV *) -1)
143 PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
144 else
145 PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
146 }
147 else
148 {
149 Perl_warn(aTHX_ "Cannot find package '%.*s'",(int) pkglen,pkg);
150 code = -1;
151 }
152 }
153 }
154 return code;
155}
156
157PerlIO *
158PerlIOVia_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
159{
160 if (!f)
161 {
162 f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX),self,mode,PerlIOArg);
163 }
164 else
165 {
166 if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
167 return NULL;
168 }
169 if (f)
170 {
171 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
172 SV *result = Nullsv;
173 if (fd >= 0)
174 {
175 SV *fdsv = sv_2mortal(newSViv(fd));
176 result = PerlIOVia_method(aTHX_ f,MYMethod(FDOPEN),G_SCALAR,fdsv,Nullsv);
177 }
178 else if (narg > 0)
179 {
180 if (*mode == '#')
181 {
182 SV *imodesv = sv_2mortal(newSViv(imode));
183 SV *permsv = sv_2mortal(newSViv(perm));
184 result = PerlIOVia_method(aTHX_ f,MYMethod(SYSOPEN),G_SCALAR,*args,imodesv,permsv,Nullsv);
185 }
186 else
187 {
188 result = PerlIOVia_method(aTHX_ f,MYMethod(OPEN),G_SCALAR,*args,Nullsv);
189 }
190 }
191 if (result)
192 {
193 if (sv_isobject(result))
194 s->obj = SvREFCNT_inc(result);
195 else if (!SvTRUE(result))
196 {
197 return NULL;
198 }
199 }
200 else
201 return NULL;
202 }
203 return f;
204}
205
206IV
207PerlIOVia_popped(PerlIO *f)
208{
209 dTHX;
210 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
211 PerlIOVia_method(aTHX_ f,MYMethod(POPPED),G_VOID,Nullsv);
212 if (s->var)
213 {
214 SvREFCNT_dec(s->var);
215 s->var = Nullsv;
216 }
217
218 if (s->io)
219 {
220 IoIFP(s->io) = NULL;
221 IoOFP(s->io) = NULL;
222 }
223 if (s->fh)
224 {
225 SvREFCNT_dec(s->fh);
226 s->fh = Nullsv;
227 s->io = NULL;
228 }
229 if (s->obj)
230 {
231 SvREFCNT_dec(s->obj);
232 s->obj = Nullsv;
233 }
234 return 0;
235}
236
237IV
238PerlIOVia_close(PerlIO *f)
239{
240 dTHX;
241 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
242 IV code = PerlIOBase_close(f);
243 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(CLOSE),G_SCALAR,Nullsv);
244 if (result && SvIV(result) != 0)
245 code = SvIV(result);
246 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
247 return code;
248}
249
250IV
251PerlIOVia_fileno(PerlIO *f)
252{
253 dTHX;
254 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
255 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILENO),G_SCALAR,Nullsv);
256 return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
257}
258
259IV
260PerlIOVia_seek(PerlIO *f, Off_t offset, int whence)
261{
262 dTHX;
263 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
264 SV *offsv = sv_2mortal(newSViv(offset));
265 SV *whsv = sv_2mortal(newSViv(offset));
266 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
267 return (result) ? SvIV(result) : -1;
268}
269
270Off_t
271PerlIOVia_tell(PerlIO *f)
272{
273 dTHX;
274 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
275 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
276 return (result) ? (Off_t) SvIV(result) : s->posn;
277}
278
279SSize_t
280PerlIOVia_unread(PerlIO *f, const void *vbuf, Size_t count)
281{
282 dTHX;
283 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
284 SV *buf = sv_2mortal(newSVpvn((char *)vbuf,count));
285 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(UNREAD),G_SCALAR,buf,Nullsv);
286 if (result)
287 return (SSize_t) SvIV(result);
288 else
289 {
290 return PerlIOBase_unread(f,vbuf,count);
291 }
292}
293
294SSize_t
295PerlIOVia_read(PerlIO *f, void *vbuf, Size_t count)
296{
297 SSize_t rd = 0;
298 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
299 {
300 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)
301 {
302 rd = PerlIOBase_read(f,vbuf,count);
303 }
304 else
305 {
306 dTHX;
307 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
308 SV *buf = sv_2mortal(newSV(count));
309 SV *n = sv_2mortal(newSViv(count));
310 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(READ),G_SCALAR,buf,n,Nullsv);
311 if (result)
312 {
313 rd = (SSize_t) SvIV(result);
314 Move(SvPVX(buf),vbuf,rd,char);
315 return rd;
316 }
317 }
318 }
319 return rd;
320}
321
322SSize_t
323PerlIOVia_write(PerlIO *f, const void *vbuf, Size_t count)
324{
325 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
326 {
327 dTHX;
328 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
329 SV *buf = newSVpvn((char *)vbuf,count);
330 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(WRITE),G_SCALAR,buf,Nullsv);
331 SvREFCNT_dec(buf);
332 if (result)
333 return (SSize_t) SvIV(result);
334 return -1;
335 }
336 return 0;
337}
338
339IV
340PerlIOVia_fill(PerlIO *f)
341{
342 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
343 {
344 dTHX;
345 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
346 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILL),G_SCALAR,Nullsv);
347 if (s->var)
348 {
349 SvREFCNT_dec(s->var);
350 s->var = Nullsv;
351 }
352 if (result && SvOK(result))
353 {
354 STRLEN len = 0;
355 char *p = SvPV(result,len);
356 s->var = newSVpvn(p,len);
357 s->cnt = SvCUR(s->var);
358 return 0;
359 }
360 else
361 PerlIOBase(f)->flags |= PERLIO_F_EOF;
362 }
363 return -1;
364}
365
366IV
367PerlIOVia_flush(PerlIO *f)
368{
369 dTHX;
370 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
371 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FLUSH),G_SCALAR,Nullsv);
372 if (s->var && s->cnt > 0)
373 {
374 SvREFCNT_dec(s->var);
375 s->var = Nullsv;
376 }
377 return (result) ? SvIV(result) : 0;
378}
379
380STDCHAR *
381PerlIOVia_get_base(PerlIO *f)
382{
383 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
384 {
385 dTHX;
386 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
387 if (s->var)
388 {
389 return (STDCHAR *)SvPVX(s->var);
390 }
391 }
392 return (STDCHAR *) Nullch;
393}
394
395STDCHAR *
396PerlIOVia_get_ptr(PerlIO *f)
397{
398 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
399 {
400 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
401 if (s->var)
402 {
403 dTHX;
404 STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
405 return p;
406 }
407 }
408 return (STDCHAR *) Nullch;
409}
410
411SSize_t
412PerlIOVia_get_cnt(PerlIO *f)
413{
414 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
415 {
416 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
417 if (s->var)
418 {
419 return s->cnt;
420 }
421 }
422 return 0;
423}
424
425Size_t
426PerlIOVia_bufsiz(PerlIO *f)
427{
428 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
429 {
430 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
431 if (s->var)
432 return SvCUR(s->var);
433 }
434 return 0;
435}
436
437void
438PerlIOVia_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
439{
440 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
441 s->cnt = cnt;
442}
443
444void
445PerlIOVia_setlinebuf(PerlIO *f)
446{
447 dTHX;
448 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
449 PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
450 PerlIOBase_setlinebuf(f);
451}
452
453void
454PerlIOVia_clearerr(PerlIO *f)
455{
456 dTHX;
457 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
458 PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
459 PerlIOBase_clearerr(f);
460}
461
462IV
463PerlIOVia_error(PerlIO *f)
464{
465 dTHX;
466 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
467 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(ERROR),G_SCALAR,Nullsv);
468 return (result) ? SvIV(result) : PerlIOBase_error(f);
469}
470
471SV *
472PerlIOVia_getarg(PerlIO *f)
473{
474 dTHX;
475 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
476 return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
477}
478
479IV
480PerlIOVia_eof(PerlIO *f)
481{
482 dTHX;
483 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
484 SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
485 return (result) ? SvIV(result) : PerlIOBase_eof(f);
486}
487
488PerlIO_funcs PerlIO_object = {
489 "Via",
490 sizeof(PerlIOVia),
491 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
492 PerlIOVia_pushed,
493 PerlIOVia_popped,
494 NULL, /* PerlIOVia_open, */
495 PerlIOVia_getarg,
496 PerlIOVia_fileno,
497 PerlIOVia_read,
498 PerlIOVia_unread,
499 PerlIOVia_write,
500 PerlIOVia_seek,
501 PerlIOVia_tell,
502 PerlIOVia_close,
503 PerlIOVia_flush,
504 PerlIOVia_fill,
505 PerlIOVia_eof,
506 PerlIOVia_error,
507 PerlIOVia_clearerr,
508 PerlIOVia_setlinebuf,
509 PerlIOVia_get_base,
510 PerlIOVia_bufsiz,
511 PerlIOVia_get_ptr,
512 PerlIOVia_get_cnt,
513 PerlIOVia_set_ptrcnt,
514};
515
516
517#endif /* Layers available */
518
519MODULE = PerlIO::Via PACKAGE = PerlIO::Via
520PROTOTYPES: ENABLE;
521
522BOOT:
523{
524#ifdef PERLIO_LAYERS
525 PerlIO_define_layer(aTHX_ &PerlIO_object);
526#endif
527}
528