This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ext/ + -Wall
[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  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;
36  CV *mERROR;
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    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
111 IV
112 PerlIOVia_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);
128      s->obj = SvREFCNT_inc(arg);
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))
137           {
138            s->obj = SvREFCNT_inc(result);
139            SvREFCNT_dec(arg);
140           }
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);
152 #ifdef ENOSYS
153        errno = ENOSYS;
154 #else
155 #ifdef ENOENT
156        errno = ENOENT;
157 #endif
158 #endif
159        code = -1;
160       }
161     }
162   }
163  return code;
164 }
165
166 PerlIO *
167 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)
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
215 IV
216 PerlIOVia_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
246 IV
247 PerlIOVia_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
259 IV
260 PerlIOVia_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
268 IV
269 PerlIOVia_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
279 Off_t
280 PerlIOVia_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
288 SSize_t
289 PerlIOVia_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
303 SSize_t
304 PerlIOVia_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
331 SSize_t
332 PerlIOVia_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
348 IV
349 PerlIOVia_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
375 IV
376 PerlIOVia_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
389 STDCHAR *
390 PerlIOVia_get_base(PerlIO *f)
391 {
392  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
393   {
394    dTHX;
395    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
396    if (s->var)
397     {
398      return (STDCHAR *)SvPVX(s->var);
399     }
400   }
401  return (STDCHAR *) Nullch;
402 }
403
404 STDCHAR *
405 PerlIOVia_get_ptr(PerlIO *f)
406 {
407  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
408   {
409    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
410    if (s->var)
411     {
412      STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
413      return p;
414     }
415   }
416  return (STDCHAR *) Nullch;
417 }
418
419 SSize_t
420 PerlIOVia_get_cnt(PerlIO *f)
421 {
422  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
423   {
424    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
425    if (s->var)
426     {
427      return s->cnt;
428     }
429   }
430  return 0;
431 }
432
433 Size_t
434 PerlIOVia_bufsiz(PerlIO *f)
435 {
436  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
437   {
438    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
439    if (s->var)
440     return SvCUR(s->var);
441   }
442  return 0;
443 }
444
445 void
446 PerlIOVia_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
447 {
448  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
449  s->cnt = cnt;
450 }
451
452 void
453 PerlIOVia_setlinebuf(PerlIO *f)
454 {
455  dTHX;
456  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
457  PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
458  PerlIOBase_setlinebuf(f);
459 }
460
461 void
462 PerlIOVia_clearerr(PerlIO *f)
463 {
464  dTHX;
465  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
466  PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
467  PerlIOBase_clearerr(f);
468 }
469
470 SV *
471 PerlIOVia_getarg(PerlIO *f)
472 {
473  dTHX;
474  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
475  return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
476 }
477
478 IV
479 PerlIOVia_error(PerlIO *f)
480 {
481  dTHX;
482  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
483  SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
484  return (result) ? SvIV(result) : PerlIOBase_error(f);
485 }
486
487 IV
488 PerlIOVia_eof(PerlIO *f)
489 {
490  dTHX;
491  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
492  SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
493  return (result) ? SvIV(result) : PerlIOBase_eof(f);
494 }
495
496 PerlIO_funcs PerlIO_object = {
497  "Via",
498  sizeof(PerlIOVia),
499  PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
500  PerlIOVia_pushed,
501  PerlIOVia_popped,
502  NULL, /* PerlIOVia_open, */
503  PerlIOVia_getarg,
504  PerlIOVia_fileno,
505  PerlIOVia_read,
506  PerlIOVia_unread,
507  PerlIOVia_write,
508  PerlIOVia_seek,
509  PerlIOVia_tell,
510  PerlIOVia_close,
511  PerlIOVia_flush,
512  PerlIOVia_fill,
513  PerlIOVia_eof,
514  PerlIOVia_error,
515  PerlIOVia_clearerr,
516  PerlIOVia_setlinebuf,
517  PerlIOVia_get_base,
518  PerlIOVia_bufsiz,
519  PerlIOVia_get_ptr,
520  PerlIOVia_get_cnt,
521  PerlIOVia_set_ptrcnt,
522 };
523
524
525 #endif /* Layers available */
526
527 MODULE = PerlIO::Via    PACKAGE = PerlIO::Via
528 PROTOTYPES: ENABLE;
529
530 BOOT:
531 {
532 #ifdef PERLIO_LAYERS
533  PerlIO_define_layer(aTHX_ &PerlIO_object);
534 #endif
535 }
536