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; |
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 |
37 | CV *mEOF; |
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 | { |
51 | return *save = GvCV(gv); |
52 | } |
53 | else |
54 | { |
55 | return *save = (CV *) -1; |
56 | } |
57 | |
58 | } |
59 | |
60 | SV * |
61 | PerlIOVia_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 | |
112 | IV |
113 | PerlIOVia_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 | |
157 | PerlIO * |
158 | PerlIOVia_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 | |
206 | IV |
207 | PerlIOVia_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 | |
237 | IV |
238 | PerlIOVia_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 | |
250 | IV |
251 | PerlIOVia_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 | |
259 | IV |
260 | PerlIOVia_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 | |
270 | Off_t |
271 | PerlIOVia_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 | |
279 | SSize_t |
280 | PerlIOVia_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 | |
294 | SSize_t |
295 | PerlIOVia_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 | |
322 | SSize_t |
323 | PerlIOVia_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 | |
339 | IV |
340 | PerlIOVia_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 | |
366 | IV |
367 | PerlIOVia_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 | |
380 | STDCHAR * |
381 | PerlIOVia_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 | |
395 | STDCHAR * |
396 | PerlIOVia_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 | |
411 | SSize_t |
412 | PerlIOVia_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 | |
425 | Size_t |
426 | PerlIOVia_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 | |
437 | void |
438 | PerlIOVia_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) |
439 | { |
440 | PerlIOVia *s = PerlIOSelf(f,PerlIOVia); |
441 | s->cnt = cnt; |
442 | } |
443 | |
444 | void |
445 | PerlIOVia_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 | |
453 | void |
454 | PerlIOVia_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 | |
c7997937 |
462 | SV * |
463 | PerlIOVia_getarg(PerlIO *f) |
e7a1fdd7 |
464 | { |
465 | dTHX; |
466 | PerlIOVia *s = PerlIOSelf(f,PerlIOVia); |
c7997937 |
467 | return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv); |
e7a1fdd7 |
468 | } |
469 | |
c7997937 |
470 | IV |
471 | PerlIOVia_error(PerlIO *f) |
e7a1fdd7 |
472 | { |
473 | dTHX; |
474 | PerlIOVia *s = PerlIOSelf(f,PerlIOVia); |
c7997937 |
475 | SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv); |
476 | return (result) ? SvIV(result) : PerlIOBase_error(f); |
e7a1fdd7 |
477 | } |
478 | |
479 | IV |
480 | PerlIOVia_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 | |
488 | PerlIO_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 | |
519 | MODULE = PerlIO::Via PACKAGE = PerlIO::Via |
520 | PROTOTYPES: ENABLE; |
521 | |
522 | BOOT: |
523 | { |
524 | #ifdef PERLIO_LAYERS |
525 | PerlIO_define_layer(aTHX_ &PerlIO_object); |
526 | #endif |
527 | } |
528 | |