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