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