This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
d1d4e644f0dc5df6da6954606108ac91a709f402
[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      Perl_warn(aTHX_ "No package specified");
119      code = -1;
120     }
121    else
122     {
123      STRLEN pkglen = 0;
124      char *pkg = SvPV(arg,pkglen);
125      s->obj = SvREFCNT_inc(arg);
126      s->stash  = gv_stashpvn(pkg, pkglen, FALSE);
127      if (s->stash)
128       {
129        SV *modesv = (mode) ? sv_2mortal(newSVpvn(mode,strlen(mode))) : Nullsv;
130        SV *result = PerlIOVia_method(aTHX_ f,MYMethod(PUSHED),G_SCALAR,modesv,Nullsv);
131        if (result)
132         {
133          if (sv_isobject(result))
134           {
135            s->obj = SvREFCNT_inc(result);
136            SvREFCNT_dec(arg);
137           }
138          else if (SvIV(result) != 0)
139           return SvIV(result);
140         }
141        if (PerlIOVia_fetchmethod(aTHX_ s,MYMethod(FILL)) == (CV *) -1)
142         PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;
143        else
144         PerlIOBase(f)->flags |= PERLIO_F_FASTGETS;
145       }
146      else
147       {
148        Perl_warn(aTHX_ "Cannot find package '%.*s'",(int) pkglen,pkg);
149 #ifdef ENOSYS
150        errno = ENOSYS;
151 #else
152 #ifdef ENOENT
153        errno = ENOENT;
154 #endif
155 #endif
156        code = -1;
157       }
158     }
159   }
160  return code;
161 }
162
163 PerlIO *
164 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)
165 {
166  if (!f)
167   {
168    f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX),self,mode,PerlIOArg);
169   }
170  else
171   {
172    if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
173     return NULL;
174   }
175  if (f)
176   {
177    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
178    SV *result = Nullsv;
179    if (fd >= 0)
180     {
181      SV *fdsv = sv_2mortal(newSViv(fd));
182      result = PerlIOVia_method(aTHX_ f,MYMethod(FDOPEN),G_SCALAR,fdsv,Nullsv);
183     }
184    else if (narg > 0)
185     {
186      if (*mode == '#')
187       {
188        SV *imodesv = sv_2mortal(newSViv(imode));
189        SV *permsv  = sv_2mortal(newSViv(perm));
190        result = PerlIOVia_method(aTHX_ f,MYMethod(SYSOPEN),G_SCALAR,*args,imodesv,permsv,Nullsv);
191       }
192      else
193       {
194        result = PerlIOVia_method(aTHX_ f,MYMethod(OPEN),G_SCALAR,*args,Nullsv);
195       }
196     }
197    if (result)
198     {
199      if (sv_isobject(result))
200       s->obj = SvREFCNT_inc(result);
201      else if (!SvTRUE(result))
202       {
203        return NULL;
204       }
205     }
206    else
207     return NULL;
208   }
209  return f;
210 }
211
212 IV
213 PerlIOVia_popped(pTHX_ PerlIO *f)
214 {
215  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
216  PerlIOVia_method(aTHX_ f,MYMethod(POPPED),G_VOID,Nullsv);
217  if (s->var)
218   {
219    SvREFCNT_dec(s->var);
220    s->var = Nullsv;
221   }
222
223  if (s->io)
224   {
225    IoIFP(s->io) = NULL;
226    IoOFP(s->io) = NULL;
227   }
228  if (s->fh)
229   {
230    SvREFCNT_dec(s->fh);
231    s->fh  = Nullsv;
232    s->io  = NULL;
233   }
234  if (s->obj)
235   {
236    SvREFCNT_dec(s->obj);
237    s->obj = Nullsv;
238   }
239  return 0;
240 }
241
242 IV
243 PerlIOVia_close(pTHX_ PerlIO *f)
244 {
245  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
246  IV code = PerlIOBase_close(aTHX_ f);
247  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(CLOSE),G_SCALAR,Nullsv);
248  if (result && SvIV(result) != 0)
249   code = SvIV(result);
250  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
251  return code;
252 }
253
254 IV
255 PerlIOVia_fileno(pTHX_ PerlIO *f)
256 {
257  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
258  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILENO),G_SCALAR,Nullsv);
259  return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f));
260 }
261
262 IV
263 PerlIOVia_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
264 {
265  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
266  SV *offsv  = sv_2mortal(newSViv(offset));
267  SV *whsv   = sv_2mortal(newSViv(whence));
268  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(SEEK),G_SCALAR,offsv,whsv,Nullsv);
269  return (result) ? SvIV(result) : -1;
270 }
271
272 Off_t
273 PerlIOVia_tell(pTHX_ PerlIO *f)
274 {
275  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
276  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(TELL),G_SCALAR,Nullsv);
277  return (result) ? (Off_t) SvIV(result) : (Off_t) -1;
278 }
279
280 SSize_t
281 PerlIOVia_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
282 {
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(aTHX_ f,vbuf,count);
291   }
292 }
293
294 SSize_t
295 PerlIOVia_read(pTHX_ 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(aTHX_ f,vbuf,count);
303     }
304    else
305     {
306      PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
307      SV *buf    = sv_2mortal(newSV(count));
308      SV *n      = sv_2mortal(newSViv(count));
309      SV *result = PerlIOVia_method(aTHX_ f,MYMethod(READ),G_SCALAR,buf,n,Nullsv);
310      if (result)
311       {
312        rd = (SSize_t) SvIV(result);
313        Move(SvPVX(buf),vbuf,rd,char);
314        return rd;
315       }
316     }
317   }
318  return rd;
319 }
320
321 SSize_t
322 PerlIOVia_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
323 {
324  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
325   {
326    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
327    SV *buf    = newSVpvn((char *)vbuf,count);
328    SV *result = PerlIOVia_method(aTHX_ f,MYMethod(WRITE),G_SCALAR,buf,Nullsv);
329    SvREFCNT_dec(buf);
330    if (result)
331     return (SSize_t) SvIV(result);
332    return -1;
333   }
334  return 0;
335 }
336
337 IV
338 PerlIOVia_fill(pTHX_ PerlIO *f)
339 {
340  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
341   {
342    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
343    SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FILL),G_SCALAR,Nullsv);
344    if (s->var)
345     {
346      SvREFCNT_dec(s->var);
347      s->var = Nullsv;
348     }
349    if (result && SvOK(result))
350     {
351      STRLEN len = 0;
352      char *p = SvPV(result,len);
353      s->var = newSVpvn(p,len);
354      s->cnt = SvCUR(s->var);
355      return 0;
356     }
357    else
358     PerlIOBase(f)->flags |= PERLIO_F_EOF;
359   }
360  return -1;
361 }
362
363 IV
364 PerlIOVia_flush(pTHX_ PerlIO *f)
365 {
366  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
367  SV *result = PerlIOVia_method(aTHX_ f,MYMethod(FLUSH),G_SCALAR,Nullsv);
368  if (s->var && s->cnt > 0)
369   {
370    SvREFCNT_dec(s->var);
371    s->var = Nullsv;
372   }
373  return (result) ? SvIV(result) : 0;
374 }
375
376 STDCHAR *
377 PerlIOVia_get_base(pTHX_ PerlIO *f)
378 {
379  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
380   {
381    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
382    if (s->var)
383     {
384      return (STDCHAR *)SvPVX(s->var);
385     }
386   }
387  return (STDCHAR *) Nullch;
388 }
389
390 STDCHAR *
391 PerlIOVia_get_ptr(pTHX_ PerlIO *f)
392 {
393  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
394   {
395    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
396    if (s->var)
397     {
398      STDCHAR *p = (STDCHAR *)(SvEND(s->var) - s->cnt);
399      return p;
400     }
401   }
402  return (STDCHAR *) Nullch;
403 }
404
405 SSize_t
406 PerlIOVia_get_cnt(pTHX_ PerlIO *f)
407 {
408  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
409   {
410    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
411    if (s->var)
412     {
413      return s->cnt;
414     }
415   }
416  return 0;
417 }
418
419 Size_t
420 PerlIOVia_bufsiz(pTHX_ PerlIO *f)
421 {
422  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
423   {
424    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
425    if (s->var)
426     return SvCUR(s->var);
427   }
428  return 0;
429 }
430
431 void
432 PerlIOVia_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR *ptr, SSize_t cnt)
433 {
434  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
435  s->cnt = cnt;
436 }
437
438 void
439 PerlIOVia_setlinebuf(pTHX_ PerlIO *f)
440 {
441  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
442  PerlIOVia_method(aTHX_ f,MYMethod(SETLINEBUF),G_VOID,Nullsv);
443  PerlIOBase_setlinebuf(aTHX_ f);
444 }
445
446 void
447 PerlIOVia_clearerr(pTHX_ PerlIO *f)
448 {
449  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
450  PerlIOVia_method(aTHX_ f,MYMethod(CLEARERR),G_VOID,Nullsv);
451  PerlIOBase_clearerr(aTHX_ f);
452 }
453
454 IV
455 PerlIOVia_error(pTHX_ PerlIO *f)
456 {
457  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
458  SV *result = PerlIOVia_method(aTHX_ f,"ERROR",&s->mERROR,G_SCALAR,Nullsv);
459  return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f);
460 }
461
462 IV
463 PerlIOVia_eof(pTHX_ PerlIO *f)
464 {
465  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
466  SV *result = PerlIOVia_method(aTHX_ f,"EOF",&s->mEOF,G_SCALAR,Nullsv);
467  return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f);
468 }
469
470 SV *
471 PerlIOVia_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
472 {
473  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
474  return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
475 }
476
477 PerlIO *
478 PerlIOVia_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
479 {
480  if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)))
481   {
482    /* Most of the fields will lazily set themselves up as needed
483       stash and obj have been set up by the implied push
484     */
485   }
486  return f;
487 }
488
489 PerlIO_funcs PerlIO_object = {
490  "Via",
491  sizeof(PerlIOVia),
492  PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
493  PerlIOVia_pushed,
494  PerlIOVia_popped,
495  NULL, /* PerlIOVia_open, */
496  PerlIOVia_getarg,
497  PerlIOVia_fileno,
498  PerlIOVia_dup,
499  PerlIOVia_read,
500  PerlIOVia_unread,
501  PerlIOVia_write,
502  PerlIOVia_seek,
503  PerlIOVia_tell,
504  PerlIOVia_close,
505  PerlIOVia_flush,
506  PerlIOVia_fill,
507  PerlIOVia_eof,
508  PerlIOVia_error,
509  PerlIOVia_clearerr,
510  PerlIOVia_setlinebuf,
511  PerlIOVia_get_base,
512  PerlIOVia_bufsiz,
513  PerlIOVia_get_ptr,
514  PerlIOVia_get_cnt,
515  PerlIOVia_set_ptrcnt,
516 };
517
518
519 #endif /* Layers available */
520
521 MODULE = PerlIO::Via    PACKAGE = PerlIO::Via
522 PROTOTYPES: ENABLE;
523
524 BOOT:
525 {
526 #ifdef PERLIO_LAYERS
527  PerlIO_define_layer(aTHX_ &PerlIO_object);
528 #endif
529 }
530