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                if (SvUTF8(sv))
 540                     XSRETURN_YES;
 541                else
 542                     XSRETURN_NO;
 543           }
 544      }
 545      XSRETURN_EMPTY;
 546 }
 547
 548 XS(XS_utf8_valid)
 549 {
 550      dXSARGS;
 551      if (items != 1)
 552           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 553      {
 554           SV *  sv = ST(0);
 555           {
 556                STRLEN len;
 557                char *s = SvPV(sv,len);
 558                if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
 559                     XSRETURN_YES;
 560                else
 561                     XSRETURN_NO;
 562           }
 563      }
 564      XSRETURN_EMPTY;
 565 }
 566
 567 XS(XS_utf8_encode)
 568 {
 569     dXSARGS;
 570     if (items != 1)
 571         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 572     {
 573         SV *    sv = ST(0);
 574
 575         sv_utf8_encode(sv);
 576     }
 577     XSRETURN_EMPTY;
 578 }
 579
 580 XS(XS_utf8_decode)
 581 {
 582     dXSARGS;
 583     if (items != 1)
 584         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 585     {
 586         SV *    sv = ST(0);
 587         bool    RETVAL;
 588
 589         RETVAL = sv_utf8_decode(sv);
 590         ST(0) = boolSV(RETVAL);
 591         sv_2mortal(ST(0));
 592     }
 593     XSRETURN(1);
 594 }
 595
 596 XS(XS_utf8_upgrade)
 597 {
 598     dXSARGS;
 599     if (items != 1)
 600         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 601     {
 602         SV *    sv = ST(0);
 603         STRLEN  RETVAL;
 604         dXSTARG;
 605
 606         RETVAL = sv_utf8_upgrade(sv);
 607         XSprePUSH; PUSHi((IV)RETVAL);
 608     }
 609     XSRETURN(1);
 610 }
 611
 612 XS(XS_utf8_downgrade)
 613 {
 614     dXSARGS;
 615     if (items < 1 || items > 2)
 616         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 617     {
 618         SV *    sv = ST(0);
 619         bool    failok;
 620         bool    RETVAL;
 621
 622         if (items < 2)
 623             failok = 0;
 624         else {
 625             failok = (int)SvIV(ST(1));
 626         }
 627
 628         RETVAL = sv_utf8_downgrade(sv, failok);
 629         ST(0) = boolSV(RETVAL);
 630         sv_2mortal(ST(0));
 631     }
 632     XSRETURN(1);
 633 }
 634
 635 XS(XS_utf8_native_to_unicode)
 636 {
 637  dXSARGS;
 638  UV uv = SvUV(ST(0));
 639
 640  if (items > 1)
 641      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 642
 643  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 644  XSRETURN(1);
 645 }
 646
 647 XS(XS_utf8_unicode_to_native)
 648 {
 649  dXSARGS;
 650  UV uv = SvUV(ST(0));
 651
 652  if (items > 1)
 653      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 654
 655  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 656  XSRETURN(1);
 657 }
 658
 659 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 660 {
 661     dXSARGS;
 662     SV *sv = SvRV(ST(0));
 663     if (items == 1) {
 664          if (SvREADONLY(sv))
 665              XSRETURN_YES;
 666          else
 667              XSRETURN_NO;
 668     }
 669     else if (items == 2) {
 670         if (SvTRUE(ST(1))) {
 671             SvREADONLY_on(sv);
 672             XSRETURN_YES;
 673         }
 674         else {
 675             /* I hope you really know what you are doing. */
 676             SvREADONLY_off(sv);
 677             XSRETURN_NO;
 678         }
 679     }
 680     XSRETURN_UNDEF; /* Can't happen. */
 681 }
 682
 683 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 684 {
 685     dXSARGS;
 686     SV *sv = SvRV(ST(0));
 687     if (items == 1)
 688          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 689     else if (items == 2) {
 690          /* I hope you really know what you are doing. */
 691          SvREFCNT(sv) = SvIV(ST(1));
 692          XSRETURN_IV(SvREFCNT(sv));
 693     }
 694     XSRETURN_UNDEF; /* Can't happen. */
 695 }
 696
 697 /* Maybe this should return the number of placeholders found in scalar context,
 698    and a list of them in list context.  */
 699 XS(XS_Internals_hv_clear_placehold)
 700 {
 701     dXSARGS;
 702     HV *hv = (HV *) SvRV(ST(0));
 703
 704     /* I don't care how many parameters were passed in, but I want to avoid
 705        the unused variable warning. */
 706
 707     items = (I32)HvPLACEHOLDERS(hv);
 708
 709     if (items) {
 710         HE *entry;
 711         I32 riter = HvRITER(hv);
 712         HE *eiter = HvEITER(hv);
 713         hv_iterinit(hv);
 714         /* This may look suboptimal with the items *after* the iternext, but
 715            it's quite deliberate. We only get here with items==0 if we've
 716            just deleted the last placeholder in the hash. If we've just done
 717            that then it means that the hash is in lazy delete mode, and the
 718            HE is now only referenced in our iterator. If we just quit the loop
 719            and discarded our iterator then the HE leaks. So we do the && the
 720            other way to ensure iternext is called just one more time, which
 721            has the side effect of triggering the lazy delete.  */
 722         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
 723             && items) {
 724             SV *val = hv_iterval(hv, entry);
 725
 726             if (val == &PL_sv_undef) {
 727
 728                 /* It seems that I have to go back in the front of the hash
 729                    API to delete a hash, even though I have a HE structure
 730                    pointing to the very entry I want to delete, and could hold
 731                    onto the previous HE that points to it. And it's easier to
 732                    go in with SVs as I can then specify the precomputed hash,
 733                    and don't have fun and games with utf8 keys.  */
 734                 SV *key = hv_iterkeysv(entry);
 735
 736                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
 737                 items--;
 738             }
 739         }
 740         HvRITER(hv) = riter;
 741         HvEITER(hv) = eiter;
 742     }
 743
 744     XSRETURN(0);
 745 }
 746
 747 XS(XS_Regexp_DESTROY)
 748 {
 749
 750 }
 751
 752 XS(XS_PerlIO_get_layers)
 753 {
 754     dXSARGS;
 755     if (items < 1 || items % 2 == 0)
 756         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
 757 #ifdef USE_PERLIO
 758     {
 759         SV *    sv;
 760         GV *    gv;
 761         IO *    io;
 762         bool    input = TRUE;
 763         bool    details = FALSE;
 764
 765         if (items > 1) {
 766              SV **svp;
 767
 768              for (svp = MARK + 2; svp <= SP; svp += 2) {
 769                   SV **varp = svp;
 770                   SV **valp = svp + 1;
 771                   STRLEN klen;
 772                   char *key = SvPV(*varp, klen);
 773
 774                   switch (*key) {
 775                   case 'i':
 776                        if (klen == 5 && memEQ(key, "input", 5)) {
 777                             input = SvTRUE(*valp);
 778                             break;
 779                        }
 780                        goto fail;
 781                   case 'o':
 782                        if (klen == 6 && memEQ(key, "output", 6)) {
 783                             input = !SvTRUE(*valp);
 784                             break;
 785                        }
 786                        goto fail;
 787                   case 'd':
 788                        if (klen == 7 && memEQ(key, "details", 7)) {
 789                             details = SvTRUE(*valp);
 790                             break;
 791                        }
 792                        goto fail;
 793                   default:
 794                   fail:
 795                        Perl_croak(aTHX_
 796                                   "get_layers: unknown argument '%s'",
 797                                   key);
 798                   }
 799              }
 800
 801              SP -= (items - 1);
 802         }
 803
 804         sv = POPs;
 805         gv = (GV*)sv;
 806
 807         if (!isGV(sv)) {
 808              if (SvROK(sv) && isGV(SvRV(sv)))
 809                   gv = (GV*)SvRV(sv);
 810              else
 811                   gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
 812         }
 813
 814         if (gv && (io = GvIO(gv))) {
 815              dTARGET;
 816              AV* av = PerlIO_get_layers(aTHX_ input ?
 817                                         IoIFP(io) : IoOFP(io));
 818              I32 i;
 819              I32 last = av_len(av);
 820              I32 nitem = 0;
 821
 822              for (i = last; i >= 0; i -= 3) {
 823                   SV **namsvp;
 824                   SV **argsvp;
 825                   SV **flgsvp;
 826                   bool namok, argok, flgok;
 827
 828                   namsvp = av_fetch(av, i - 2, FALSE);
 829                   argsvp = av_fetch(av, i - 1, FALSE);
 830                   flgsvp = av_fetch(av, i,     FALSE);
 831
 832                   namok = namsvp && *namsvp && SvPOK(*namsvp);
 833                   argok = argsvp && *argsvp && SvPOK(*argsvp);
 834                   flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 835
 836                   if (details) {
 837                        XPUSHs(namok ?
 838                              newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
 839                        XPUSHs(argok ?
 840                              newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
 841                        if (flgok)
 842                             XPUSHi(SvIVX(*flgsvp));
 843                        else
 844                             XPUSHs(&PL_sv_undef);
 845                        nitem += 3;
 846                   }
 847                   else {
 848                        if (namok && argok)
 849                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 850                                                *namsvp, *argsvp));
 851                        else if (namok)
 852                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
 853                        else
 854                             XPUSHs(&PL_sv_undef);
 855                        nitem++;
 856                        if (flgok) {
 857                             IV flags = SvIVX(*flgsvp);
 858
 859                             if (flags & PERLIO_F_UTF8) {
 860                                  XPUSHs(newSVpvn("utf8", 4));
 861                                  nitem++;
 862                             }
 863                        }
 864                   }
 865              }
 866
 867              SvREFCNT_dec(av);
 868
 869              XSRETURN(nitem);
 870         }
 871     }
 872 #endif
 873
 874     XSRETURN(0);
 875 }
 876