This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
warnings for perlio + others
[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;
e7a1fdd7
NIS
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
NIS
36 CV *mEOF;
37} PerlIOVia;
38
39#define MYMethod(x) #x,&s->x
40
41CV *
42PerlIOVia_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
NIS
56}
57
58SV *
59PerlIOVia_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
NIS
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
109IV
f62ce20a 110PerlIOVia_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
e7a1fdd7 111{
f62ce20a 112 IV code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv);
e7a1fdd7
NIS
113 if (code == 0)
114 {
e7a1fdd7
NIS
115 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
116 if (!arg)
117 {
99ef548b
PM
118 if (ckWARN(WARN_LAYER))
119 Perl_warner(aTHX_ packWARN(WARN_LAYER), "No package specified");
e7a1fdd7
NIS
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
NIS
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
NIS
135 {
136 s->obj = SvREFCNT_inc(result);
137 SvREFCNT_dec(arg);
138 }
e7a1fdd7
NIS
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 {
99ef548b
PM
149 if (ckWARN(WARN_LAYER))
150 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Cannot find package '%.*s'",(int) pkglen,pkg);
267cbce7
NIS
151#ifdef ENOSYS
152 errno = ENOSYS;
153#else
154#ifdef ENOENT
155 errno = ENOENT;
156#endif
157#endif
e7a1fdd7
NIS
158 code = -1;
159 }
160 }
161 }
162 return code;
163}
164
165PerlIO *
fcf2db38 166PerlIOVia_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
167{
168 if (!f)
169 {
170 f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX),self,mode,PerlIOArg);
171 }
172 else
173 {
174 if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
175 return NULL;
176 }
177 if (f)
178 {
179 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
180 SV *result = Nullsv;
181 if (fd >= 0)
182 {
183 SV *fdsv = sv_2mortal(newSViv(fd));
184 result = PerlIOVia_method(aTHX_ f,MYMethod(FDOPEN),G_SCALAR,fdsv,Nullsv);
185 }
186 else if (narg > 0)
187 {
188 if (*mode == '#')
189 {
190 SV *imodesv = sv_2mortal(newSViv(imode));
191 SV *permsv = sv_2mortal(newSViv(perm));
192 result = PerlIOVia_method(aTHX_ f,MYMethod(SYSOPEN),G_SCALAR,*args,imodesv,permsv,Nullsv);
193 }
194 else
195 {
196 result = PerlIOVia_method(aTHX_ f,MYMethod(OPEN),G_SCALAR,*args,Nullsv);
197 }
198 }
199 if (result)
200 {
201 if (sv_isobject(result))
202 s->obj = SvREFCNT_inc(result);
203 else if (!SvTRUE(result))
204 {
205 return NULL;
206 }
207 }
208 else
209 return NULL;
210 }
211 return f;
212}
213
214IV
f62ce20a 215PerlIOVia_popped(pTHX_ PerlIO *f)
e7a1fdd7 216{
e7a1fdd7
NIS
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
244IV
f62ce20a 245PerlIOVia_close(pTHX_ PerlIO *f)
e7a1fdd7 246{
e7a1fdd7 247 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
f62ce20a 248 IV code = PerlIOBase_close(aTHX_ f);
e7a1fdd7
NIS
249 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(CLOSE),G_SCALAR,Nullsv);
250 if (result && SvIV(result) != 0)
251 code = SvIV(result);
252 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
253 return code;
254}
255
256IV
f62ce20a 257PerlIOVia_fileno(pTHX_ PerlIO *f)
e7a1fdd7 258{
e7a1fdd7
NIS
259 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
260 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILENO),G_SCALAR,Nullsv);
261 return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
262}
263
264IV
f62ce20a 265PerlIOVia_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
e7a1fdd7 266{
e7a1fdd7
NIS
267 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
268 SV *offsv = sv_2mortal(newSViv(offset));
9f16d962 269 SV *whsv = sv_2mortal(newSViv(whence));
e7a1fdd7
NIS
270 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
271 return (result) ? SvIV(result) : -1;
272}
273
274Off_t
f62ce20a 275PerlIOVia_tell(pTHX_ PerlIO *f)
e7a1fdd7 276{
e7a1fdd7
NIS
277 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
278 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
9f16d962 279 return (result) ? (Off_t) SvIV(result) : (Off_t) -1;
e7a1fdd7
NIS
280}
281
282SSize_t
f62ce20a 283PerlIOVia_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
e7a1fdd7 284{
e7a1fdd7
NIS
285 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
286 SV *buf = sv_2mortal(newSVpvn((char *)vbuf,count));
287 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(UNREAD),G_SCALAR,buf,Nullsv);
288 if (result)
289 return (SSize_t) SvIV(result);
290 else
291 {
f62ce20a 292 return PerlIOBase_unread(aTHX_ f,vbuf,count);
e7a1fdd7
NIS
293 }
294}
295
296SSize_t
f62ce20a 297PerlIOVia_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
e7a1fdd7
NIS
298{
299 SSize_t rd = 0;
300 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
301 {
302 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)
303 {
f62ce20a 304 rd = PerlIOBase_read(aTHX_ f,vbuf,count);
e7a1fdd7
NIS
305 }
306 else
307 {
e7a1fdd7
NIS
308 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
309 SV *buf = sv_2mortal(newSV(count));
310 SV *n = sv_2mortal(newSViv(count));
311 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(READ),G_SCALAR,buf,n,Nullsv);
312 if (result)
313 {
314 rd = (SSize_t) SvIV(result);
315 Move(SvPVX(buf),vbuf,rd,char);
316 return rd;
317 }
318 }
319 }
320 return rd;
321}
322
323SSize_t
f62ce20a 324PerlIOVia_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
e7a1fdd7
NIS
325{
326 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
327 {
e7a1fdd7
NIS
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
f62ce20a 340PerlIOVia_fill(pTHX_ PerlIO *f)
e7a1fdd7
NIS
341{
342 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
343 {
e7a1fdd7
NIS
344 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
345 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILL),G_SCALAR,Nullsv);
346 if (s->var)
347 {
348 SvREFCNT_dec(s->var);
349 s->var = Nullsv;
350 }
351 if (result && SvOK(result))
352 {
353 STRLEN len = 0;
354 char *p = SvPV(result,len);
355 s->var = newSVpvn(p,len);
356 s->cnt = SvCUR(s->var);
357 return 0;
358 }
359 else
360 PerlIOBase(f)->flags |= PERLIO_F_EOF;
361 }
362 return -1;
363}
364
365IV
f62ce20a 366PerlIOVia_flush(pTHX_ PerlIO *f)
e7a1fdd7 367{
e7a1fdd7
NIS
368 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
369 SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FLUSH),G_SCALAR,Nullsv);
370 if (s->var && s->cnt > 0)
371 {
372 SvREFCNT_dec(s->var);
373 s->var = Nullsv;
374 }
375 return (result) ? SvIV(result) : 0;
376}
377
378STDCHAR *
f62ce20a 379PerlIOVia_get_base(pTHX_ PerlIO *f)
e7a1fdd7
NIS
380{
381 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
382 {
e7a1fdd7
NIS
383 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
384 if (s->var)
385 {
386 return (STDCHAR *)SvPVX(s->var);
387 }
388 }
389 return (STDCHAR *) Nullch;
390}
391
392STDCHAR *
f62ce20a 393PerlIOVia_get_ptr(pTHX_ PerlIO *f)
e7a1fdd7
NIS
394{
395 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
396 {
397 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
398 if (s->var)
399 {
e7a1fdd7
NIS
400 STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
401 return p;
402 }
403 }
404 return (STDCHAR *) Nullch;
405}
406
407SSize_t
f62ce20a 408PerlIOVia_get_cnt(pTHX_ PerlIO *f)
e7a1fdd7
NIS
409{
410 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
411 {
412 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
413 if (s->var)
414 {
415 return s->cnt;
416 }
417 }
418 return 0;
419}
420
421Size_t
f62ce20a 422PerlIOVia_bufsiz(pTHX_ PerlIO *f)
e7a1fdd7
NIS
423{
424 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
425 {
426 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
427 if (s->var)
428 return SvCUR(s->var);
429 }
430 return 0;
431}
432
433void
f62ce20a 434PerlIOVia_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR *ptr, SSize_t cnt)
e7a1fdd7
NIS
435{
436 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
437 s->cnt = cnt;
438}
439
440void
f62ce20a 441PerlIOVia_setlinebuf(pTHX_ PerlIO *f)
e7a1fdd7 442{
e7a1fdd7
NIS
443 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
444 PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
f62ce20a 445 PerlIOBase_setlinebuf(aTHX_ f);
e7a1fdd7
NIS
446}
447
448void
f62ce20a 449PerlIOVia_clearerr(pTHX_ PerlIO *f)
e7a1fdd7 450{
e7a1fdd7
NIS
451 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
452 PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
f62ce20a 453 PerlIOBase_clearerr(aTHX_ f);
e7a1fdd7
NIS
454}
455
c7997937 456IV
f62ce20a 457PerlIOVia_error(pTHX_ PerlIO *f)
e7a1fdd7 458{
e7a1fdd7 459 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
c7997937 460 SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
f62ce20a 461 return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
e7a1fdd7
NIS
462}
463
464IV
f62ce20a 465PerlIOVia_eof(pTHX_ PerlIO *f)
e7a1fdd7 466{
e7a1fdd7
NIS
467 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
468 SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
f62ce20a 469 return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
e7a1fdd7
NIS
470}
471
ecdeb87c
NIS
472SV *
473PerlIOVia_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
474{
475 PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
476 return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
477}
478
8cf8f3d1 479PerlIO *
ecdeb87c 480PerlIOVia_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
8cf8f3d1 481{
ecdeb87c 482 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)))
9f16d962 483 {
ecdeb87c 484 /* Most of the fields will lazily set themselves up as needed
9f16d962
NIS
485 stash and obj have been set up by the implied push
486 */
487 }
488 return f;
8cf8f3d1
NIS
489}
490
e7a1fdd7
NIS
491PerlIO_funcs PerlIO_object = {
492 "Via",
493 sizeof(PerlIOVia),
494 PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
495 PerlIOVia_pushed,
496 PerlIOVia_popped,
497 NULL, /* PerlIOVia_open, */
498 PerlIOVia_getarg,
499 PerlIOVia_fileno,
8cf8f3d1 500 PerlIOVia_dup,
e7a1fdd7
NIS
501 PerlIOVia_read,
502 PerlIOVia_unread,
503 PerlIOVia_write,
504 PerlIOVia_seek,
505 PerlIOVia_tell,
506 PerlIOVia_close,
507 PerlIOVia_flush,
508 PerlIOVia_fill,
509 PerlIOVia_eof,
510 PerlIOVia_error,
511 PerlIOVia_clearerr,
512 PerlIOVia_setlinebuf,
513 PerlIOVia_get_base,
514 PerlIOVia_bufsiz,
515 PerlIOVia_get_ptr,
516 PerlIOVia_get_cnt,
517 PerlIOVia_set_ptrcnt,
518};
519
520
521#endif /* Layers available */
522
523MODULE = PerlIO::Via PACKAGE = PerlIO::Via
524PROTOTYPES: ENABLE;
525
526BOOT:
527{
528#ifdef PERLIO_LAYERS
529 PerlIO_define_layer(aTHX_ &PerlIO_object);
530#endif
531}
532