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