Re: [MacOS X] consider useshrplib='false' by default
[perl.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_valid);
175 XS(XS_utf8_encode);
176 XS(XS_utf8_decode);
177 XS(XS_utf8_upgrade);
178 XS(XS_utf8_downgrade);
179 XS(XS_utf8_unicode_to_native);
180 XS(XS_utf8_native_to_unicode);
181 XS(XS_Internals_SvREADONLY);
182 XS(XS_Internals_SvREFCNT);
183 XS(XS_Internals_hv_clear_placehold);
184 XS(XS_PerlIO_get_layers);
185 XS(XS_Regexp_DESTROY);
186
187 void
188 Perl_boot_core_UNIVERSAL(pTHX)
189 {
190     char *file = __FILE__;
191
192     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
193     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
194     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
195     {
196         /* register the overloading (type 'A') magic */
197         PL_amagic_generation++;
198         /* Make it findable via fetchmethod */
199         newXS("version::()", XS_version_noop, file);
200         newXS("version::new", XS_version_new, file);
201         newXS("version::(\"\"", XS_version_stringify, file);
202         newXS("version::stringify", XS_version_stringify, file);
203         newXS("version::(0+", XS_version_numify, file);
204         newXS("version::numify", XS_version_numify, file);
205         newXS("version::(cmp", XS_version_vcmp, file);
206         newXS("version::(<=>", XS_version_vcmp, file);
207         newXS("version::vcmp", XS_version_vcmp, file);
208         newXS("version::(bool", XS_version_boolean, file);
209         newXS("version::boolean", XS_version_boolean, file);
210         newXS("version::(nomethod", XS_version_noop, file);
211         newXS("version::noop", XS_version_noop, file);
212     }
213     newXS("utf8::valid", XS_utf8_valid, file);
214     newXS("utf8::encode", XS_utf8_encode, file);
215     newXS("utf8::decode", XS_utf8_decode, file);
216     newXS("utf8::upgrade", XS_utf8_upgrade, file);
217     newXS("utf8::downgrade", XS_utf8_downgrade, file);
218     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
219     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
220     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
221     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
222     newXSproto("Internals::hv_clear_placeholders",
223                XS_Internals_hv_clear_placehold, file, "\\%");
224     newXSproto("PerlIO::get_layers",
225                XS_PerlIO_get_layers, file, "*;@");
226     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
227 }
228
229
230 XS(XS_UNIVERSAL_isa)
231 {
232     dXSARGS;
233     SV *sv;
234     char *name;
235     STRLEN n_a;
236
237     if (items != 2)
238         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
239
240     sv = ST(0);
241
242     if (SvGMAGICAL(sv))
243         mg_get(sv);
244
245     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
246                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
247         XSRETURN_UNDEF;
248
249     name = (char *)SvPV(ST(1),n_a);
250
251     ST(0) = boolSV(sv_derived_from(sv, name));
252     XSRETURN(1);
253 }
254
255 XS(XS_UNIVERSAL_can)
256 {
257     dXSARGS;
258     SV   *sv;
259     char *name;
260     SV   *rv;
261     HV   *pkg = NULL;
262     STRLEN n_a;
263
264     if (items != 2)
265         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
266
267     sv = ST(0);
268
269     if (SvGMAGICAL(sv))
270         mg_get(sv);
271
272     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
273                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
274         XSRETURN_UNDEF;
275
276     name = (char *)SvPV(ST(1),n_a);
277     rv = &PL_sv_undef;
278
279     if (SvROK(sv)) {
280         sv = (SV*)SvRV(sv);
281         if (SvOBJECT(sv))
282             pkg = SvSTASH(sv);
283     }
284     else {
285         pkg = gv_stashsv(sv, FALSE);
286     }
287
288     if (pkg) {
289         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
290         if (gv && isGV(gv))
291             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
292     }
293
294     ST(0) = rv;
295     XSRETURN(1);
296 }
297
298 XS(XS_UNIVERSAL_VERSION)
299 {
300     dXSARGS;
301     HV *pkg;
302     GV **gvp;
303     GV *gv;
304     SV *sv;
305     char *undef;
306
307     if (SvROK(ST(0))) {
308         sv = (SV*)SvRV(ST(0));
309         if (!SvOBJECT(sv))
310             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
311         pkg = SvSTASH(sv);
312     }
313     else {
314         pkg = gv_stashsv(ST(0), FALSE);
315     }
316
317     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
318
319     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
320         SV *nsv = sv_newmortal();
321         sv_setsv(nsv, sv);
322         sv = nsv;
323         undef = Nullch;
324     }
325     else {
326         sv = (SV*)&PL_sv_undef;
327         undef = "(undef)";
328     }
329
330     if (items > 1) {
331         STRLEN len;
332         SV *req = ST(1);
333
334         if (undef) {
335              if (pkg)
336                   Perl_croak(aTHX_
337                              "%s does not define $%s::VERSION--version check failed",
338                              HvNAME(pkg), HvNAME(pkg));
339              else {
340                   char *str = SvPVx(ST(0), len);
341
342                   Perl_croak(aTHX_
343                              "%s defines neither package nor VERSION--version check failed", str);
344              }
345         }
346         if ( !sv_derived_from(sv, "version"))
347             sv = new_version(sv);
348
349         if ( !sv_derived_from(req, "version"))
350             req = new_version(req);
351
352         if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
353             Perl_croak(aTHX_
354                 "%s version %"SVf" required--this is only version %"SVf,
355                 HvNAME(pkg), req, sv);
356     }
357
358     ST(0) = sv;
359
360     XSRETURN(1);
361 }
362
363 XS(XS_version_new)
364 {
365     dXSARGS;
366     if (items > 3)
367         Perl_croak(aTHX_ "Usage: version::new(class, version)");
368     SP -= items;
369     {
370 /*      char *  class = (char *)SvPV_nolen(ST(0)); */
371         SV *version = ST(1);
372         if (items == 3 )
373         {
374             char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
375             version = Perl_newSVpvf(aTHX_ "v%s",vs);
376         }
377
378         PUSHs(new_version(version));
379         PUTBACK;
380         return;
381     }
382 }
383
384 XS(XS_version_stringify)
385 {
386     dXSARGS;
387     if (items < 1)
388         Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
389     SP -= items;
390     {
391         SV *    lobj;
392
393         if (sv_derived_from(ST(0), "version")) {
394                 SV *tmp = SvRV(ST(0));
395                 lobj = tmp;
396         }
397         else
398                 Perl_croak(aTHX_ "lobj is not of type version");
399
400 {
401     PUSHs(vstringify(lobj));
402 }
403
404         PUTBACK;
405         return;
406     }
407 }
408
409 XS(XS_version_numify)
410 {
411     dXSARGS;
412     if (items < 1)
413         Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
414     SP -= items;
415     {
416         SV *    lobj;
417
418         if (sv_derived_from(ST(0), "version")) {
419                 SV *tmp = SvRV(ST(0));
420                 lobj = tmp;
421         }
422         else
423                 Perl_croak(aTHX_ "lobj is not of type version");
424
425 {
426     PUSHs(vnumify(lobj));
427 }
428
429         PUTBACK;
430         return;
431     }
432 }
433
434 XS(XS_version_vcmp)
435 {
436     dXSARGS;
437     if (items < 1)
438         Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
439     SP -= items;
440     {
441         SV *    lobj;
442
443         if (sv_derived_from(ST(0), "version")) {
444                 SV *tmp = SvRV(ST(0));
445                 lobj = tmp;
446         }
447         else
448                 Perl_croak(aTHX_ "lobj is not of type version");
449
450 {
451     SV  *rs;
452     SV  *rvs;
453     SV * robj = ST(1);
454     IV   swap = (IV)SvIV(ST(2));
455
456     if ( ! sv_derived_from(robj, "version") )
457     {
458         robj = new_version(robj);
459     }
460     rvs = SvRV(robj);
461
462     if ( swap )
463     {
464         rs = newSViv(vcmp(rvs,lobj));
465     }
466     else
467     {
468         rs = newSViv(vcmp(lobj,rvs));
469     }
470
471     PUSHs(rs);
472 }
473
474         PUTBACK;
475         return;
476     }
477 }
478
479 XS(XS_version_boolean)
480 {
481     dXSARGS;
482     if (items < 1)
483         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
484     SP -= items;
485     {
486         SV *    lobj;
487
488         if (sv_derived_from(ST(0), "version")) {
489                 SV *tmp = SvRV(ST(0));
490                 lobj = tmp;
491         }
492         else
493                 Perl_croak(aTHX_ "lobj is not of type version");
494
495 {
496     SV  *rs;
497     rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
498     PUSHs(rs);
499 }
500
501         PUTBACK;
502         return;
503     }
504 }
505
506 XS(XS_version_noop)
507 {
508     dXSARGS;
509     if (items < 1)
510         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
511     {
512         SV *    lobj;
513
514         if (sv_derived_from(ST(0), "version")) {
515                 SV *tmp = SvRV(ST(0));
516                 lobj = tmp;
517         }
518         else
519                 Perl_croak(aTHX_ "lobj is not of type version");
520
521 {
522     Perl_croak(aTHX_ "operation not supported with version object");
523 }
524
525     }
526     XSRETURN_EMPTY;
527 }
528
529 XS(XS_utf8_valid)
530 {
531     dXSARGS;
532     if (items != 1)
533         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
534     {
535         SV *    sv = ST(0);
536  {
537   STRLEN len;
538   char *s = SvPV(sv,len);
539   if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
540    XSRETURN_YES;
541   else
542    XSRETURN_NO;
543  }
544     }
545     XSRETURN_EMPTY;
546 }
547
548 XS(XS_utf8_encode)
549 {
550     dXSARGS;
551     if (items != 1)
552         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
553     {
554         SV *    sv = ST(0);
555
556         sv_utf8_encode(sv);
557     }
558     XSRETURN_EMPTY;
559 }
560
561 XS(XS_utf8_decode)
562 {
563     dXSARGS;
564     if (items != 1)
565         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
566     {
567         SV *    sv = ST(0);
568         bool    RETVAL;
569
570         RETVAL = sv_utf8_decode(sv);
571         ST(0) = boolSV(RETVAL);
572         sv_2mortal(ST(0));
573     }
574     XSRETURN(1);
575 }
576
577 XS(XS_utf8_upgrade)
578 {
579     dXSARGS;
580     if (items != 1)
581         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
582     {
583         SV *    sv = ST(0);
584         STRLEN  RETVAL;
585         dXSTARG;
586
587         RETVAL = sv_utf8_upgrade(sv);
588         XSprePUSH; PUSHi((IV)RETVAL);
589     }
590     XSRETURN(1);
591 }
592
593 XS(XS_utf8_downgrade)
594 {
595     dXSARGS;
596     if (items < 1 || items > 2)
597         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
598     {
599         SV *    sv = ST(0);
600         bool    failok;
601         bool    RETVAL;
602
603         if (items < 2)
604             failok = 0;
605         else {
606             failok = (int)SvIV(ST(1));
607         }
608
609         RETVAL = sv_utf8_downgrade(sv, failok);
610         ST(0) = boolSV(RETVAL);
611         sv_2mortal(ST(0));
612     }
613     XSRETURN(1);
614 }
615
616 XS(XS_utf8_native_to_unicode)
617 {
618  dXSARGS;
619  UV uv = SvUV(ST(0));
620
621  if (items > 1)
622      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
623
624  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
625  XSRETURN(1);
626 }
627
628 XS(XS_utf8_unicode_to_native)
629 {
630  dXSARGS;
631  UV uv = SvUV(ST(0));
632
633  if (items > 1)
634      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
635
636  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
637  XSRETURN(1);
638 }
639
640 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
641 {
642     dXSARGS;
643     SV *sv = SvRV(ST(0));
644     if (items == 1) {
645          if (SvREADONLY(sv))
646              XSRETURN_YES;
647          else
648              XSRETURN_NO;
649     }
650     else if (items == 2) {
651         if (SvTRUE(ST(1))) {
652             SvREADONLY_on(sv);
653             XSRETURN_YES;
654         }
655         else {
656             /* I hope you really know what you are doing. */
657             SvREADONLY_off(sv);
658             XSRETURN_NO;
659         }
660     }
661     XSRETURN_UNDEF; /* Can't happen. */
662 }
663
664 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
665 {
666     dXSARGS;
667     SV *sv = SvRV(ST(0));
668     if (items == 1)
669          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
670     else if (items == 2) {
671          /* I hope you really know what you are doing. */
672          SvREFCNT(sv) = SvIV(ST(1));
673          XSRETURN_IV(SvREFCNT(sv));
674     }
675     XSRETURN_UNDEF; /* Can't happen. */
676 }
677
678 /* Maybe this should return the number of placeholders found in scalar context,
679    and a list of them in list context.  */
680 XS(XS_Internals_hv_clear_placehold)
681 {
682     dXSARGS;
683     HV *hv = (HV *) SvRV(ST(0));
684
685     /* I don't care how many parameters were passed in, but I want to avoid
686        the unused variable warning. */
687
688     items = (I32)HvPLACEHOLDERS(hv);
689
690     if (items) {
691         HE *entry;
692         I32 riter = HvRITER(hv);
693         HE *eiter = HvEITER(hv);
694         hv_iterinit(hv);
695         /* This may look suboptimal with the items *after* the iternext, but
696            it's quite deliberate. We only get here with items==0 if we've
697            just deleted the last placeholder in the hash. If we've just done
698            that then it means that the hash is in lazy delete mode, and the
699            HE is now only referenced in our iterator. If we just quit the loop
700            and discarded our iterator then the HE leaks. So we do the && the
701            other way to ensure iternext is called just one more time, which
702            has the side effect of triggering the lazy delete.  */
703         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
704             && items) {
705             SV *val = hv_iterval(hv, entry);
706
707             if (val == &PL_sv_undef) {
708
709                 /* It seems that I have to go back in the front of the hash
710                    API to delete a hash, even though I have a HE structure
711                    pointing to the very entry I want to delete, and could hold
712                    onto the previous HE that points to it. And it's easier to
713                    go in with SVs as I can then specify the precomputed hash,
714                    and don't have fun and games with utf8 keys.  */
715                 SV *key = hv_iterkeysv(entry);
716
717                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
718                 items--;
719             }
720         }
721         HvRITER(hv) = riter;
722         HvEITER(hv) = eiter;
723     }
724
725     XSRETURN(0);
726 }
727
728 XS(XS_Regexp_DESTROY)
729 {
730
731 }
732
733 XS(XS_PerlIO_get_layers)
734 {
735     dXSARGS;
736     if (items < 1 || items % 2 == 0)
737         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
738 #ifdef USE_PERLIO
739     {
740         SV *    sv;
741         GV *    gv;
742         IO *    io;
743         bool    input = TRUE;
744         bool    details = FALSE;
745
746         if (items > 1) {
747              SV **svp;
748              
749              for (svp = MARK + 2; svp <= SP; svp += 2) {
750                   SV **varp = svp;
751                   SV **valp = svp + 1;
752                   STRLEN klen;
753                   char *key = SvPV(*varp, klen);
754
755                   switch (*key) {
756                   case 'i':
757                        if (klen == 5 && memEQ(key, "input", 5)) {
758                             input = SvTRUE(*valp);
759                             break;
760                        }
761                        goto fail;
762                   case 'o': 
763                        if (klen == 6 && memEQ(key, "output", 6)) {
764                             input = !SvTRUE(*valp);
765                             break;
766                        }
767                        goto fail;
768                   case 'd':
769                        if (klen == 7 && memEQ(key, "details", 7)) {
770                             details = SvTRUE(*valp);
771                             break;
772                        }
773                        goto fail;
774                   default:
775                   fail:
776                        Perl_croak(aTHX_
777                                   "get_layers: unknown argument '%s'",
778                                   key);
779                   }
780              }
781
782              SP -= (items - 1);
783         }
784
785         sv = POPs;
786         gv = (GV*)sv;
787
788         if (!isGV(sv)) {
789              if (SvROK(sv) && isGV(SvRV(sv)))
790                   gv = (GV*)SvRV(sv);
791              else
792                   gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
793         }
794
795         if (gv && (io = GvIO(gv))) {
796              dTARGET;
797              AV* av = PerlIO_get_layers(aTHX_ input ?
798                                         IoIFP(io) : IoOFP(io));
799              I32 i;
800              I32 last = av_len(av);
801              I32 nitem = 0;
802              
803              for (i = last; i >= 0; i -= 3) {
804                   SV **namsvp;
805                   SV **argsvp;
806                   SV **flgsvp;
807                   bool namok, argok, flgok;
808
809                   namsvp = av_fetch(av, i - 2, FALSE);
810                   argsvp = av_fetch(av, i - 1, FALSE);
811                   flgsvp = av_fetch(av, i,     FALSE);
812
813                   namok = namsvp && *namsvp && SvPOK(*namsvp);
814                   argok = argsvp && *argsvp && SvPOK(*argsvp);
815                   flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
816
817                   if (details) {
818                        XPUSHs(namok ?
819                              newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
820                        XPUSHs(argok ?
821                              newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
822                        if (flgok)
823                             XPUSHi(SvIVX(*flgsvp));
824                        else
825                             XPUSHs(&PL_sv_undef);
826                        nitem += 3;
827                   }
828                   else {
829                        if (namok && argok)
830                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
831                                                *namsvp, *argsvp));
832                        else if (namok)
833                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
834                        else
835                             XPUSHs(&PL_sv_undef);
836                        nitem++;
837                        if (flgok) {
838                             IV flags = SvIVX(*flgsvp);
839
840                             if (flags & PERLIO_F_UTF8) {
841                                  XPUSHs(newSVpvn("utf8", 4));
842                                  nitem++;
843                             }
844                        }
845                   }
846              }
847
848              SvREFCNT_dec(av);
849
850              XSRETURN(nitem);
851         }
852     }
853 #endif
854
855     XSRETURN(0);
856 }
857