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