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