This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Unused variable.
[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