This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
0fe94d2225dfbad5b7d752a988e46416dd942182
[perl5.git] / universal.c
1 /*    universal.c
2  *
3  *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4  *    by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * "The roots of those mountains must be roots indeed; there must be
13  * great secrets buried there which have not been discovered since the
14  * beginning." --Gandalf, relating Gollum's story
15  */
16
17 #include "EXTERN.h"
18 #define PERL_IN_UNIVERSAL_C
19 #include "perl.h"
20
21 #ifdef USE_PERLIO
22 #include "perliol.h" /* For the PERLIO_F_XXX */
23 #endif
24
25 /*
26  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
27  * The main guts of traverse_isa was actually copied from gv_fetchmeth
28  */
29
30 STATIC SV *
31 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
32              int len, int level)
33 {
34     AV* av;
35     GV* gv;
36     GV** gvp;
37     HV* hv = Nullhv;
38     SV* subgen = Nullsv;
39
40     /* A stash/class can go by many names (ie. User == main::User), so 
41        we compare the stash itself just in case */
42     if (name_stash && (stash == name_stash))
43         return &PL_sv_yes;
44
45     if (strEQ(HvNAME(stash), name))
46         return &PL_sv_yes;
47
48     if (level > 100)
49         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
50                    HvNAME(stash));
51
52     gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
53
54     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
55         && (hv = GvHV(gv)))
56     {
57         if (SvIV(subgen) == (IV)PL_sub_generation) {
58             SV* sv;
59             SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
60             if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
61                 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
62                                   name, HvNAME(stash)) );
63                 return sv;
64             }
65         }
66         else {
67             DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
68                               HvNAME(stash)) );
69             hv_clear(hv);
70             sv_setiv(subgen, PL_sub_generation);
71         }
72     }
73
74     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
75
76     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
77         if (!hv || !subgen) {
78             gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
79
80             gv = *gvp;
81
82             if (SvTYPE(gv) != SVt_PVGV)
83                 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
84
85             if (!hv)
86                 hv = GvHVn(gv);
87             if (!subgen) {
88                 subgen = newSViv(PL_sub_generation);
89                 GvSV(gv) = subgen;
90             }
91         }
92         if (hv) {
93             SV** svp = AvARRAY(av);
94             /* NOTE: No support for tied ISA */
95             I32 items = AvFILLp(av) + 1;
96             while (items--) {
97                 SV* sv = *svp++;
98                 HV* basestash = gv_stashsv(sv, FALSE);
99                 if (!basestash) {
100                     if (ckWARN(WARN_MISC))
101                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
102                              "Can't locate package %"SVf" for @%s::ISA",
103                             sv, HvNAME(stash));
104                     continue;
105                 }
106                 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, 
107                                              len, level + 1)) {
108                     (void)hv_store(hv,name,len,&PL_sv_yes,0);
109                     return &PL_sv_yes;
110                 }
111             }
112             (void)hv_store(hv,name,len,&PL_sv_no,0);
113         }
114     }
115
116     return boolSV(strEQ(name, "UNIVERSAL"));
117 }
118
119 /*
120 =head1 SV Manipulation Functions
121
122 =for apidoc sv_derived_from
123
124 Returns a boolean indicating whether the SV is derived from the specified
125 class.  This is the function that implements C<UNIVERSAL::isa>.  It works
126 for class names as well as for objects.
127
128 =cut
129 */
130
131 bool
132 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
133 {
134     char *type;
135     HV *stash;
136     HV *name_stash;
137
138     stash = Nullhv;
139     type = Nullch;
140
141     if (SvGMAGICAL(sv))
142         mg_get(sv) ;
143
144     if (SvROK(sv)) {
145         sv = SvRV(sv);
146         type = sv_reftype(sv,0);
147         if (SvOBJECT(sv))
148             stash = SvSTASH(sv);
149     }
150     else {
151         stash = gv_stashsv(sv, FALSE);
152     }
153
154     name_stash = gv_stashpv(name, FALSE);
155
156     return (type && strEQ(type,name)) ||
157             (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) 
158              == &PL_sv_yes)
159         ? TRUE
160         : FALSE ;
161 }
162
163 #include "XSUB.h"
164
165 void XS_UNIVERSAL_isa(pTHX_ CV *cv);
166 void XS_UNIVERSAL_can(pTHX_ CV *cv);
167 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
168 XS(XS_version_new);
169 XS(XS_version_stringify);
170 XS(XS_version_numify);
171 XS(XS_version_vcmp);
172 XS(XS_version_boolean);
173 XS(XS_version_noop);
174 XS(XS_utf8_is_utf8);
175 XS(XS_utf8_valid);
176 XS(XS_utf8_encode);
177 XS(XS_utf8_decode);
178 XS(XS_utf8_upgrade);
179 XS(XS_utf8_downgrade);
180 XS(XS_utf8_unicode_to_native);
181 XS(XS_utf8_native_to_unicode);
182 XS(XS_Internals_SvREADONLY);
183 XS(XS_Internals_SvREFCNT);
184 XS(XS_Internals_hv_clear_placehold);
185 XS(XS_PerlIO_get_layers);
186 XS(XS_Regexp_DESTROY);
187
188 void
189 Perl_boot_core_UNIVERSAL(pTHX)
190 {
191     char *file = __FILE__;
192
193     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
194     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
195     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
196     {
197         /* register the overloading (type 'A') magic */
198         PL_amagic_generation++;
199         /* Make it findable via fetchmethod */
200         newXS("version::()", XS_version_noop, file);
201         newXS("version::new", XS_version_new, file);
202         newXS("version::(\"\"", XS_version_stringify, file);
203         newXS("version::stringify", XS_version_stringify, file);
204         newXS("version::(0+", XS_version_numify, file);
205         newXS("version::numify", XS_version_numify, file);
206         newXS("version::(cmp", XS_version_vcmp, file);
207         newXS("version::(<=>", XS_version_vcmp, file);
208         newXS("version::vcmp", XS_version_vcmp, file);
209         newXS("version::(bool", XS_version_boolean, file);
210         newXS("version::boolean", XS_version_boolean, file);
211         newXS("version::(nomethod", XS_version_noop, file);
212         newXS("version::noop", XS_version_noop, file);
213     }
214     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
215     newXS("utf8::valid", XS_utf8_valid, file);
216     newXS("utf8::encode", XS_utf8_encode, file);
217     newXS("utf8::decode", XS_utf8_decode, file);
218     newXS("utf8::upgrade", XS_utf8_upgrade, file);
219     newXS("utf8::downgrade", XS_utf8_downgrade, file);
220     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
221     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
222     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
223     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
224     newXSproto("Internals::hv_clear_placeholders",
225                XS_Internals_hv_clear_placehold, file, "\\%");
226     newXSproto("PerlIO::get_layers",
227                XS_PerlIO_get_layers, file, "*;@");
228     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
229 }
230
231
232 XS(XS_UNIVERSAL_isa)
233 {
234     dXSARGS;
235     SV *sv;
236     char *name;
237     STRLEN n_a;
238
239     if (items != 2)
240         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
241
242     sv = ST(0);
243
244     if (SvGMAGICAL(sv))
245         mg_get(sv);
246
247     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
248                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
249         XSRETURN_UNDEF;
250
251     name = (char *)SvPV(ST(1),n_a);
252
253     ST(0) = boolSV(sv_derived_from(sv, name));
254     XSRETURN(1);
255 }
256
257 XS(XS_UNIVERSAL_can)
258 {
259     dXSARGS;
260     SV   *sv;
261     char *name;
262     SV   *rv;
263     HV   *pkg = NULL;
264     STRLEN n_a;
265
266     if (items != 2)
267         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
268
269     sv = ST(0);
270
271     if (SvGMAGICAL(sv))
272         mg_get(sv);
273
274     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
275                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
276         XSRETURN_UNDEF;
277
278     name = (char *)SvPV(ST(1),n_a);
279     rv = &PL_sv_undef;
280
281     if (SvROK(sv)) {
282         sv = (SV*)SvRV(sv);
283         if (SvOBJECT(sv))
284             pkg = SvSTASH(sv);
285     }
286     else {
287         pkg = gv_stashsv(sv, FALSE);
288     }
289
290     if (pkg) {
291         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
292         if (gv && isGV(gv))
293             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
294     }
295
296     ST(0) = rv;
297     XSRETURN(1);
298 }
299
300 XS(XS_UNIVERSAL_VERSION)
301 {
302     dXSARGS;
303     HV *pkg;
304     GV **gvp;
305     GV *gv;
306     SV *sv;
307     char *undef;
308
309     if (SvROK(ST(0))) {
310         sv = (SV*)SvRV(ST(0));
311         if (!SvOBJECT(sv))
312             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
313         pkg = SvSTASH(sv);
314     }
315     else {
316         pkg = gv_stashsv(ST(0), FALSE);
317     }
318
319     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
320
321     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
322         SV *nsv = sv_newmortal();
323         sv_setsv(nsv, sv);
324         sv = nsv;
325         undef = Nullch;
326     }
327     else {
328         sv = (SV*)&PL_sv_undef;
329         undef = "(undef)";
330     }
331
332     if (items > 1) {
333         STRLEN len;
334         SV *req = ST(1);
335
336         if (undef) {
337              if (pkg)
338                   Perl_croak(aTHX_
339                              "%s does not define $%s::VERSION--version check failed",
340                              HvNAME(pkg), HvNAME(pkg));
341              else {
342                   char *str = SvPVx(ST(0), len);
343
344                   Perl_croak(aTHX_
345                              "%s defines neither package nor VERSION--version check failed", str);
346              }
347         }
348         if ( !sv_derived_from(sv, "version"))
349             sv = new_version(sv);
350
351         if ( !sv_derived_from(req, "version"))
352             req = new_version(req);
353
354         if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
355             Perl_croak(aTHX_
356                 "%s version %"SVf" required--this is only version %"SVf,
357                 HvNAME(pkg), req, sv);
358     }
359
360     ST(0) = sv;
361
362     XSRETURN(1);
363 }
364
365 XS(XS_version_new)
366 {
367     dXSARGS;
368     if (items > 3)
369         Perl_croak(aTHX_ "Usage: version::new(class, version)");
370     SP -= items;
371     {
372 /*      char *  class = (char *)SvPV_nolen(ST(0)); */
373         SV *version = ST(1);
374         if (items == 3 )
375         {
376             char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
377             version = Perl_newSVpvf(aTHX_ "v%s",vs);
378         }
379
380         PUSHs(new_version(version));
381         PUTBACK;
382         return;
383     }
384 }
385
386 XS(XS_version_stringify)
387 {
388     dXSARGS;
389     if (items < 1)
390         Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
391     SP -= items;
392     {
393         SV *    lobj;
394
395         if (sv_derived_from(ST(0), "version")) {
396                 SV *tmp = SvRV(ST(0));
397                 lobj = tmp;
398         }
399         else
400                 Perl_croak(aTHX_ "lobj is not of type version");
401
402 {
403     PUSHs(vstringify(lobj));
404 }
405
406         PUTBACK;
407         return;
408     }
409 }
410
411 XS(XS_version_numify)
412 {
413     dXSARGS;
414     if (items < 1)
415         Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
416     SP -= items;
417     {
418         SV *    lobj;
419
420         if (sv_derived_from(ST(0), "version")) {
421                 SV *tmp = SvRV(ST(0));
422                 lobj = tmp;
423         }
424         else
425                 Perl_croak(aTHX_ "lobj is not of type version");
426
427 {
428     PUSHs(vnumify(lobj));
429 }
430
431         PUTBACK;
432         return;
433     }
434 }
435
436 XS(XS_version_vcmp)
437 {
438     dXSARGS;
439     if (items < 1)
440         Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
441     SP -= items;
442     {
443         SV *    lobj;
444
445         if (sv_derived_from(ST(0), "version")) {
446                 SV *tmp = SvRV(ST(0));
447                 lobj = tmp;
448         }
449         else
450                 Perl_croak(aTHX_ "lobj is not of type version");
451
452 {
453     SV  *rs;
454     SV  *rvs;
455     SV * robj = ST(1);
456     IV   swap = (IV)SvIV(ST(2));
457
458     if ( ! sv_derived_from(robj, "version") )
459     {
460         robj = new_version(robj);
461     }
462     rvs = SvRV(robj);
463
464     if ( swap )
465     {
466         rs = newSViv(vcmp(rvs,lobj));
467     }
468     else
469     {
470         rs = newSViv(vcmp(lobj,rvs));
471     }
472
473     PUSHs(rs);
474 }
475
476         PUTBACK;
477         return;
478     }
479 }
480
481 XS(XS_version_boolean)
482 {
483     dXSARGS;
484     if (items < 1)
485         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
486     SP -= items;
487     {
488         SV *    lobj;
489
490         if (sv_derived_from(ST(0), "version")) {
491                 SV *tmp = SvRV(ST(0));
492                 lobj = tmp;
493         }
494         else
495                 Perl_croak(aTHX_ "lobj is not of type version");
496
497 {
498     SV  *rs;
499     rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
500     PUSHs(rs);
501 }
502
503         PUTBACK;
504         return;
505     }
506 }
507
508 XS(XS_version_noop)
509 {
510     dXSARGS;
511     if (items < 1)
512         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
513     {
514         SV *    lobj;
515
516         if (sv_derived_from(ST(0), "version")) {
517                 SV *tmp = SvRV(ST(0));
518                 lobj = tmp;
519         }
520         else
521                 Perl_croak(aTHX_ "lobj is not of type version");
522
523 {
524     Perl_croak(aTHX_ "operation not supported with version object");
525 }
526
527     }
528     XSRETURN_EMPTY;
529 }
530
531 XS(XS_utf8_is_utf8)
532 {
533     dXSARGS;
534     if (items != 1)
535         Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
536     {
537         SV *    sv = ST(0);
538  {
539   STRLEN len;
540   if (SvUTF8(sv))
541    XSRETURN_YES;
542   else
543    XSRETURN_NO;
544  }
545     }
546     XSRETURN_EMPTY;
547 }
548
549 XS(XS_utf8_valid)
550 {
551     dXSARGS;
552     if (items != 1)
553         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
554     {
555         SV *    sv = ST(0);
556  {
557   STRLEN len;
558   char *s = SvPV(sv,len);
559   if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
560    XSRETURN_YES;
561   else
562    XSRETURN_NO;
563  }
564     }
565     XSRETURN_EMPTY;
566 }
567
568 XS(XS_utf8_encode)
569 {
570     dXSARGS;
571     if (items != 1)
572         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
573     {
574         SV *    sv = ST(0);
575
576         sv_utf8_encode(sv);
577     }
578     XSRETURN_EMPTY;
579 }
580
581 XS(XS_utf8_decode)
582 {
583     dXSARGS;
584     if (items != 1)
585         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
586     {
587         SV *    sv = ST(0);
588         bool    RETVAL;
589
590         RETVAL = sv_utf8_decode(sv);
591         ST(0) = boolSV(RETVAL);
592         sv_2mortal(ST(0));
593     }
594     XSRETURN(1);
595 }
596
597 XS(XS_utf8_upgrade)
598 {
599     dXSARGS;
600     if (items != 1)
601         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
602     {
603         SV *    sv = ST(0);
604         STRLEN  RETVAL;
605         dXSTARG;
606
607         RETVAL = sv_utf8_upgrade(sv);
608         XSprePUSH; PUSHi((IV)RETVAL);
609     }
610     XSRETURN(1);
611 }
612
613 XS(XS_utf8_downgrade)
614 {
615     dXSARGS;
616     if (items < 1 || items > 2)
617         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
618     {
619         SV *    sv = ST(0);
620         bool    failok;
621         bool    RETVAL;
622
623         if (items < 2)
624             failok = 0;
625         else {
626             failok = (int)SvIV(ST(1));
627         }
628
629         RETVAL = sv_utf8_downgrade(sv, failok);
630         ST(0) = boolSV(RETVAL);
631         sv_2mortal(ST(0));
632     }
633     XSRETURN(1);
634 }
635
636 XS(XS_utf8_native_to_unicode)
637 {
638  dXSARGS;
639  UV uv = SvUV(ST(0));
640
641  if (items > 1)
642      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
643
644  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
645  XSRETURN(1);
646 }
647
648 XS(XS_utf8_unicode_to_native)
649 {
650  dXSARGS;
651  UV uv = SvUV(ST(0));
652
653  if (items > 1)
654      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
655
656  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
657  XSRETURN(1);
658 }
659
660 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
661 {
662     dXSARGS;
663     SV *sv = SvRV(ST(0));
664     if (items == 1) {
665          if (SvREADONLY(sv))
666              XSRETURN_YES;
667          else
668              XSRETURN_NO;
669     }
670     else if (items == 2) {
671         if (SvTRUE(ST(1))) {
672             SvREADONLY_on(sv);
673             XSRETURN_YES;
674         }
675         else {
676             /* I hope you really know what you are doing. */
677             SvREADONLY_off(sv);
678             XSRETURN_NO;
679         }
680     }
681     XSRETURN_UNDEF; /* Can't happen. */
682 }
683
684 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
685 {
686     dXSARGS;
687     SV *sv = SvRV(ST(0));
688     if (items == 1)
689          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
690     else if (items == 2) {
691          /* I hope you really know what you are doing. */
692          SvREFCNT(sv) = SvIV(ST(1));
693          XSRETURN_IV(SvREFCNT(sv));
694     }
695     XSRETURN_UNDEF; /* Can't happen. */
696 }
697
698 /* Maybe this should return the number of placeholders found in scalar context,
699    and a list of them in list context.  */
700 XS(XS_Internals_hv_clear_placehold)
701 {
702     dXSARGS;
703     HV *hv = (HV *) SvRV(ST(0));
704
705     /* I don't care how many parameters were passed in, but I want to avoid
706        the unused variable warning. */
707
708     items = (I32)HvPLACEHOLDERS(hv);
709
710     if (items) {
711         HE *entry;
712         I32 riter = HvRITER(hv);
713         HE *eiter = HvEITER(hv);
714         hv_iterinit(hv);
715         /* This may look suboptimal with the items *after* the iternext, but
716            it's quite deliberate. We only get here with items==0 if we've
717            just deleted the last placeholder in the hash. If we've just done
718            that then it means that the hash is in lazy delete mode, and the
719            HE is now only referenced in our iterator. If we just quit the loop
720            and discarded our iterator then the HE leaks. So we do the && the
721            other way to ensure iternext is called just one more time, which
722            has the side effect of triggering the lazy delete.  */
723         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
724             && items) {
725             SV *val = hv_iterval(hv, entry);
726
727             if (val == &PL_sv_undef) {
728
729                 /* It seems that I have to go back in the front of the hash
730                    API to delete a hash, even though I have a HE structure
731                    pointing to the very entry I want to delete, and could hold
732                    onto the previous HE that points to it. And it's easier to
733                    go in with SVs as I can then specify the precomputed hash,
734                    and don't have fun and games with utf8 keys.  */
735                 SV *key = hv_iterkeysv(entry);
736
737                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
738                 items--;
739             }
740         }
741         HvRITER(hv) = riter;
742         HvEITER(hv) = eiter;
743     }
744
745     XSRETURN(0);
746 }
747
748 XS(XS_Regexp_DESTROY)
749 {
750
751 }
752
753 XS(XS_PerlIO_get_layers)
754 {
755     dXSARGS;
756     if (items < 1 || items % 2 == 0)
757         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
758 #ifdef USE_PERLIO
759     {
760         SV *    sv;
761         GV *    gv;
762         IO *    io;
763         bool    input = TRUE;
764         bool    details = FALSE;
765
766         if (items > 1) {
767              SV **svp;
768              
769              for (svp = MARK + 2; svp <= SP; svp += 2) {
770                   SV **varp = svp;
771                   SV **valp = svp + 1;
772                   STRLEN klen;
773                   char *key = SvPV(*varp, klen);
774
775                   switch (*key) {
776                   case 'i':
777                        if (klen == 5 && memEQ(key, "input", 5)) {
778                             input = SvTRUE(*valp);
779                             break;
780                        }
781                        goto fail;
782                   case 'o': 
783                        if (klen == 6 && memEQ(key, "output", 6)) {
784                             input = !SvTRUE(*valp);
785                             break;
786                        }
787                        goto fail;
788                   case 'd':
789                        if (klen == 7 && memEQ(key, "details", 7)) {
790                             details = SvTRUE(*valp);
791                             break;
792                        }
793                        goto fail;
794                   default:
795                   fail:
796                        Perl_croak(aTHX_
797                                   "get_layers: unknown argument '%s'",
798                                   key);
799                   }
800              }
801
802              SP -= (items - 1);
803         }
804
805         sv = POPs;
806         gv = (GV*)sv;
807
808         if (!isGV(sv)) {
809              if (SvROK(sv) && isGV(SvRV(sv)))
810                   gv = (GV*)SvRV(sv);
811              else
812                   gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
813         }
814
815         if (gv && (io = GvIO(gv))) {
816              dTARGET;
817              AV* av = PerlIO_get_layers(aTHX_ input ?
818                                         IoIFP(io) : IoOFP(io));
819              I32 i;
820              I32 last = av_len(av);
821              I32 nitem = 0;
822              
823              for (i = last; i >= 0; i -= 3) {
824                   SV **namsvp;
825                   SV **argsvp;
826                   SV **flgsvp;
827                   bool namok, argok, flgok;
828
829                   namsvp = av_fetch(av, i - 2, FALSE);
830                   argsvp = av_fetch(av, i - 1, FALSE);
831                   flgsvp = av_fetch(av, i,     FALSE);
832
833                   namok = namsvp && *namsvp && SvPOK(*namsvp);
834                   argok = argsvp && *argsvp && SvPOK(*argsvp);
835                   flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
836
837                   if (details) {
838                        XPUSHs(namok ?
839                              newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
840                        XPUSHs(argok ?
841                              newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
842                        if (flgok)
843                             XPUSHi(SvIVX(*flgsvp));
844                        else
845                             XPUSHs(&PL_sv_undef);
846                        nitem += 3;
847                   }
848                   else {
849                        if (namok && argok)
850                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
851                                                *namsvp, *argsvp));
852                        else if (namok)
853                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
854                        else
855                             XPUSHs(&PL_sv_undef);
856                        nitem++;
857                        if (flgok) {
858                             IV flags = SvIVX(*flgsvp);
859
860                             if (flags & PERLIO_F_UTF8) {
861                                  XPUSHs(newSVpvn("utf8", 4));
862                                  nitem++;
863                             }
864                        }
865                   }
866              }
867
868              SvREFCNT_dec(av);
869
870              XSRETURN(nitem);
871         }
872     }
873 #endif
874
875     XSRETURN(0);
876 }
877