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