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