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