This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PerlIO::Via layer (alpha-ish).
[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 *ERROR;
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
462 IV
463 PerlIOVia_error(PerlIO *f)
464 {
465  dTHX;
466  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
467  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(ERROR),G_SCALAR,Nullsv);
468  return (result) ? SvIV(result) : PerlIOBase_error(f);
469 }
470
471 SV *
472 PerlIOVia_getarg(PerlIO *f)
473 {
474  dTHX;
475  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
476  return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
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