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