universal.c

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