This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Reindent a section of the file.
[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                if (SvUTF8(sv))
540                     XSRETURN_YES;
541                else
542                     XSRETURN_NO;
543           }
544      }
545      XSRETURN_EMPTY;
546 }
547
548 XS(XS_utf8_valid)
549 {
550      dXSARGS;
551      if (items != 1)
552           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
553      {
554           SV *  sv = ST(0);
555           {
556                STRLEN len;
557                char *s = SvPV(sv,len);
558                if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
559                     XSRETURN_YES;
560                else
561                     XSRETURN_NO;
562           }
563      }
564      XSRETURN_EMPTY;
565 }
566
567 XS(XS_utf8_encode)
568 {
569     dXSARGS;
570     if (items != 1)
571         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
572     {
573         SV *    sv = ST(0);
574
575         sv_utf8_encode(sv);
576     }
577     XSRETURN_EMPTY;
578 }
579
580 XS(XS_utf8_decode)
581 {
582     dXSARGS;
583     if (items != 1)
584         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
585     {
586         SV *    sv = ST(0);
587         bool    RETVAL;
588
589         RETVAL = sv_utf8_decode(sv);
590         ST(0) = boolSV(RETVAL);
591         sv_2mortal(ST(0));
592     }
593     XSRETURN(1);
594 }
595
596 XS(XS_utf8_upgrade)
597 {
598     dXSARGS;
599     if (items != 1)
600         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
601     {
602         SV *    sv = ST(0);
603         STRLEN  RETVAL;
604         dXSTARG;
605
606         RETVAL = sv_utf8_upgrade(sv);
607         XSprePUSH; PUSHi((IV)RETVAL);
608     }
609     XSRETURN(1);
610 }
611
612 XS(XS_utf8_downgrade)
613 {
614     dXSARGS;
615     if (items < 1 || items > 2)
616         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
617     {
618         SV *    sv = ST(0);
619         bool    failok;
620         bool    RETVAL;
621
622         if (items < 2)
623             failok = 0;
624         else {
625             failok = (int)SvIV(ST(1));
626         }
627
628         RETVAL = sv_utf8_downgrade(sv, failok);
629         ST(0) = boolSV(RETVAL);
630         sv_2mortal(ST(0));
631     }
632     XSRETURN(1);
633 }
634
635 XS(XS_utf8_native_to_unicode)
636 {
637  dXSARGS;
638  UV uv = SvUV(ST(0));
639
640  if (items > 1)
641      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
642
643  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
644  XSRETURN(1);
645 }
646
647 XS(XS_utf8_unicode_to_native)
648 {
649  dXSARGS;
650  UV uv = SvUV(ST(0));
651
652  if (items > 1)
653      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
654
655  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
656  XSRETURN(1);
657 }
658
659 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
660 {
661     dXSARGS;
662     SV *sv = SvRV(ST(0));
663     if (items == 1) {
664          if (SvREADONLY(sv))
665              XSRETURN_YES;
666          else
667              XSRETURN_NO;
668     }
669     else if (items == 2) {
670         if (SvTRUE(ST(1))) {
671             SvREADONLY_on(sv);
672             XSRETURN_YES;
673         }
674         else {
675             /* I hope you really know what you are doing. */
676             SvREADONLY_off(sv);
677             XSRETURN_NO;
678         }
679     }
680     XSRETURN_UNDEF; /* Can't happen. */
681 }
682
683 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
684 {
685     dXSARGS;
686     SV *sv = SvRV(ST(0));
687     if (items == 1)
688          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
689     else if (items == 2) {
690          /* I hope you really know what you are doing. */
691          SvREFCNT(sv) = SvIV(ST(1));
692          XSRETURN_IV(SvREFCNT(sv));
693     }
694     XSRETURN_UNDEF; /* Can't happen. */
695 }
696
697 /* Maybe this should return the number of placeholders found in scalar context,
698    and a list of them in list context.  */
699 XS(XS_Internals_hv_clear_placehold)
700 {
701     dXSARGS;
702     HV *hv = (HV *) SvRV(ST(0));
703
704     /* I don't care how many parameters were passed in, but I want to avoid
705        the unused variable warning. */
706
707     items = (I32)HvPLACEHOLDERS(hv);
708
709     if (items) {
710         HE *entry;
711         I32 riter = HvRITER(hv);
712         HE *eiter = HvEITER(hv);
713         hv_iterinit(hv);
714         /* This may look suboptimal with the items *after* the iternext, but
715            it's quite deliberate. We only get here with items==0 if we've
716            just deleted the last placeholder in the hash. If we've just done
717            that then it means that the hash is in lazy delete mode, and the
718            HE is now only referenced in our iterator. If we just quit the loop
719            and discarded our iterator then the HE leaks. So we do the && the
720            other way to ensure iternext is called just one more time, which
721            has the side effect of triggering the lazy delete.  */
722         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
723             && items) {
724             SV *val = hv_iterval(hv, entry);
725
726             if (val == &PL_sv_undef) {
727
728                 /* It seems that I have to go back in the front of the hash
729                    API to delete a hash, even though I have a HE structure
730                    pointing to the very entry I want to delete, and could hold
731                    onto the previous HE that points to it. And it's easier to
732                    go in with SVs as I can then specify the precomputed hash,
733                    and don't have fun and games with utf8 keys.  */
734                 SV *key = hv_iterkeysv(entry);
735
736                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
737                 items--;
738             }
739         }
740         HvRITER(hv) = riter;
741         HvEITER(hv) = eiter;
742     }
743
744     XSRETURN(0);
745 }
746
747 XS(XS_Regexp_DESTROY)
748 {
749
750 }
751
752 XS(XS_PerlIO_get_layers)
753 {
754     dXSARGS;
755     if (items < 1 || items % 2 == 0)
756         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
757 #ifdef USE_PERLIO
758     {
759         SV *    sv;
760         GV *    gv;
761         IO *    io;
762         bool    input = TRUE;
763         bool    details = FALSE;
764
765         if (items > 1) {
766              SV **svp;
767              
768              for (svp = MARK + 2; svp <= SP; svp += 2) {
769                   SV **varp = svp;
770                   SV **valp = svp + 1;
771                   STRLEN klen;
772                   char *key = SvPV(*varp, klen);
773
774                   switch (*key) {
775                   case 'i':
776                        if (klen == 5 && memEQ(key, "input", 5)) {
777                             input = SvTRUE(*valp);
778                             break;
779                        }
780                        goto fail;
781                   case 'o': 
782                        if (klen == 6 && memEQ(key, "output", 6)) {
783                             input = !SvTRUE(*valp);
784                             break;
785                        }
786                        goto fail;
787                   case 'd':
788                        if (klen == 7 && memEQ(key, "details", 7)) {
789                             details = SvTRUE(*valp);
790                             break;
791                        }
792                        goto fail;
793                   default:
794                   fail:
795                        Perl_croak(aTHX_
796                                   "get_layers: unknown argument '%s'",
797                                   key);
798                   }
799              }
800
801              SP -= (items - 1);
802         }
803
804         sv = POPs;
805         gv = (GV*)sv;
806
807         if (!isGV(sv)) {
808              if (SvROK(sv) && isGV(SvRV(sv)))
809                   gv = (GV*)SvRV(sv);
810              else
811                   gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
812         }
813
814         if (gv && (io = GvIO(gv))) {
815              dTARGET;
816              AV* av = PerlIO_get_layers(aTHX_ input ?
817                                         IoIFP(io) : IoOFP(io));
818              I32 i;
819              I32 last = av_len(av);
820              I32 nitem = 0;
821              
822              for (i = last; i >= 0; i -= 3) {
823                   SV **namsvp;
824                   SV **argsvp;
825                   SV **flgsvp;
826                   bool namok, argok, flgok;
827
828                   namsvp = av_fetch(av, i - 2, FALSE);
829                   argsvp = av_fetch(av, i - 1, FALSE);
830                   flgsvp = av_fetch(av, i,     FALSE);
831
832                   namok = namsvp && *namsvp && SvPOK(*namsvp);
833                   argok = argsvp && *argsvp && SvPOK(*argsvp);
834                   flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
835
836                   if (details) {
837                        XPUSHs(namok ?
838                              newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
839                        XPUSHs(argok ?
840                              newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
841                        if (flgok)
842                             XPUSHi(SvIVX(*flgsvp));
843                        else
844                             XPUSHs(&PL_sv_undef);
845                        nitem += 3;
846                   }
847                   else {
848                        if (namok && argok)
849                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
850                                                *namsvp, *argsvp));
851                        else if (namok)
852                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
853                        else
854                             XPUSHs(&PL_sv_undef);
855                        nitem++;
856                        if (flgok) {
857                             IV flags = SvIVX(*flgsvp);
858
859                             if (flags & PERLIO_F_UTF8) {
860                                  XPUSHs(newSVpvn("utf8", 4));
861                                  nitem++;
862                             }
863                        }
864                   }
865              }
866
867              SvREFCNT_dec(av);
868
869              XSRETURN(nitem);
870         }
871     }
872 #endif
873
874     XSRETURN(0);
875 }
876