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
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  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;
35  CV *mERROR;
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   }
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;
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(pTHX_ PerlIO *f, const char *mode, SV *arg)
111 {
112  IV code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv);
113  if (code == 0)
114   {
115    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
116    if (!arg)
117     {
118      if (ckWARN(WARN_LAYER))
119       Perl_warner(aTHX_ packWARN(WARN_LAYER), "No package specified");
120      code = -1;
121     }
122    else
123     {
124      STRLEN pkglen = 0;
125      char *pkg = SvPV(arg,pkglen);
126      s->obj = SvREFCNT_inc(arg);
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))
135           {
136            s->obj = SvREFCNT_inc(result);
137            SvREFCNT_dec(arg);
138           }
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        if (ckWARN(WARN_LAYER))
150          Perl_warner(aTHX_ packWARN(WARN_LAYER), "Cannot find package '%.*s'",(int) pkglen,pkg);
151 #ifdef ENOSYS
152        errno = ENOSYS;
153 #else
154 #ifdef ENOENT
155        errno = ENOENT;
156 #endif
157 #endif
158        code = -1;
159       }
160     }
161   }
162  return code;
163 }
164
165 PerlIO *
166 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)
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
214 IV
215 PerlIOVia_popped(pTHX_ PerlIO *f)
216 {
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(pTHX_ PerlIO *f)
246 {
247  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
248  IV code = PerlIOBase_close(aTHX_ f);
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
256 IV
257 PerlIOVia_fileno(pTHX_ PerlIO *f)
258 {
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
264 IV
265 PerlIOVia_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
266 {
267  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
268  SV *offsv  = sv_2mortal(newSViv(offset));
269  SV *whsv   = sv_2mortal(newSViv(whence));
270  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
271  return (result) ? SvIV(result) : -1;
272 }
273
274 Off_t
275 PerlIOVia_tell(pTHX_ PerlIO *f)
276 {
277  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
278  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
279  return (result) ? (Off_t) SvIV(result) : (Off_t) -1;
280 }
281
282 SSize_t
283 PerlIOVia_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
284 {
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   {
292    return PerlIOBase_unread(aTHX_ f,vbuf,count);
293   }
294 }
295
296 SSize_t
297 PerlIOVia_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
298 {
299  SSize_t rd = 0;
300  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
301   {
302    if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)
303     {
304      rd = PerlIOBase_read(aTHX_ f,vbuf,count);
305     }
306    else
307     {
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
323 SSize_t
324 PerlIOVia_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
325 {
326  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
327   {
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(pTHX_ PerlIO *f)
341 {
342  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
343   {
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
365 IV
366 PerlIOVia_flush(pTHX_ PerlIO *f)
367 {
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
378 STDCHAR *
379 PerlIOVia_get_base(pTHX_ PerlIO *f)
380 {
381  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
382   {
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
392 STDCHAR *
393 PerlIOVia_get_ptr(pTHX_ PerlIO *f)
394 {
395  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
396   {
397    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
398    if (s->var)
399     {
400      STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
401      return p;
402     }
403   }
404  return (STDCHAR *) Nullch;
405 }
406
407 SSize_t
408 PerlIOVia_get_cnt(pTHX_ PerlIO *f)
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
421 Size_t
422 PerlIOVia_bufsiz(pTHX_ PerlIO *f)
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
433 void
434 PerlIOVia_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR *ptr, SSize_t cnt)
435 {
436  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
437  s->cnt = cnt;
438 }
439
440 void
441 PerlIOVia_setlinebuf(pTHX_ PerlIO *f)
442 {
443  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
444  PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
445  PerlIOBase_setlinebuf(aTHX_ f);
446 }
447
448 void
449 PerlIOVia_clearerr(pTHX_ PerlIO *f)
450 {
451  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
452  PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
453  PerlIOBase_clearerr(aTHX_ f);
454 }
455
456 IV
457 PerlIOVia_error(pTHX_ PerlIO *f)
458 {
459  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
460  SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
461  return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
462 }
463
464 IV
465 PerlIOVia_eof(pTHX_ PerlIO *f)
466 {
467  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
468  SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
469  return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
470 }
471
472 SV *
473 PerlIOVia_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
479 PerlIO *
480 PerlIOVia_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
481 {
482  if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)))
483   {
484    /* Most of the fields will lazily set themselves up as needed
485       stash and obj have been set up by the implied push
486     */
487   }
488  return f;
489 }
490
491 PerlIO_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,
500  PerlIOVia_dup,
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
523 MODULE = PerlIO::Via    PACKAGE = PerlIO::Via
524 PROTOTYPES: ENABLE;
525
526 BOOT:
527 {
528 #ifdef PERLIO_LAYERS
529  PerlIO_define_layer(aTHX_ &PerlIO_object);
530 #endif
531 }
532