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::new", XS_version_new, file);
 196         newXS("version::(\"\"", XS_version_stringify, file);
 197         newXS("version::stringify", XS_version_stringify, file);
 198         newXS("version::(0+", XS_version_numify, file);
 199         newXS("version::numify", XS_version_numify, file);
 200         newXS("version::(cmp", XS_version_vcmp, file);
 201         newXS("version::(<=>", XS_version_vcmp, file);
 202         newXS("version::vcmp", XS_version_vcmp, file);
 203         newXS("version::(bool", XS_version_boolean, file);
 204         newXS("version::boolean", XS_version_boolean, file);
 205         newXS("version::(nomethod", XS_version_noop, file);
 206         newXS("version::noop", XS_version_noop, file);
 207     }
 208     newXS("utf8::valid", XS_utf8_valid, file);
 209     newXS("utf8::encode", XS_utf8_encode, file);
 210     newXS("utf8::decode", XS_utf8_decode, file);
 211     newXS("utf8::upgrade", XS_utf8_upgrade, file);
 212     newXS("utf8::downgrade", XS_utf8_downgrade, file);
 213     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
 214     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
 215     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
 216     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 217     newXSproto("Internals::hv_clear_placeholders",
 218                XS_Internals_hv_clear_placehold, file, "\\%");
 219 }
 220
 221
 222 XS(XS_UNIVERSAL_isa)
 223 {
 224     dXSARGS;
 225     SV *sv;
 226     char *name;
 227     STRLEN n_a;
 228
 229     if (items != 2)
 230         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 231
 232     sv = ST(0);
 233
 234     if (SvGMAGICAL(sv))
 235         mg_get(sv);
 236
 237     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
 238         XSRETURN_UNDEF;
 239
 240     name = (char *)SvPV(ST(1),n_a);
 241
 242     ST(0) = boolSV(sv_derived_from(sv, name));
 243     XSRETURN(1);
 244 }
 245
 246 XS(XS_UNIVERSAL_can)
 247 {
 248     dXSARGS;
 249     SV   *sv;
 250     char *name;
 251     SV   *rv;
 252     HV   *pkg = NULL;
 253     STRLEN n_a;
 254
 255     if (items != 2)
 256         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 257
 258     sv = ST(0);
 259
 260     if (SvGMAGICAL(sv))
 261         mg_get(sv);
 262
 263     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
 264         XSRETURN_UNDEF;
 265
 266     name = (char *)SvPV(ST(1),n_a);
 267     rv = &PL_sv_undef;
 268
 269     if (SvROK(sv)) {
 270         sv = (SV*)SvRV(sv);
 271         if (SvOBJECT(sv))
 272             pkg = SvSTASH(sv);
 273     }
 274     else {
 275         pkg = gv_stashsv(sv, FALSE);
 276     }
 277
 278     if (pkg) {
 279         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 280         if (gv && isGV(gv))
 281             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 282     }
 283
 284     ST(0) = rv;
 285     XSRETURN(1);
 286 }
 287
 288 XS(XS_UNIVERSAL_VERSION)
 289 {
 290     dXSARGS;
 291     HV *pkg;
 292     GV **gvp;
 293     GV *gv;
 294     SV *sv;
 295     char *undef;
 296
 297     if (SvROK(ST(0))) {
 298         sv = (SV*)SvRV(ST(0));
 299         if (!SvOBJECT(sv))
 300             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 301         pkg = SvSTASH(sv);
 302     }
 303     else {
 304         pkg = gv_stashsv(ST(0), FALSE);
 305     }
 306
 307     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
 308
 309     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
 310         SV *nsv = sv_newmortal();
 311         sv_setsv(nsv, sv);
 312         sv = nsv;
 313         undef = Nullch;
 314     }
 315     else {
 316         sv = (SV*)&PL_sv_undef;
 317         undef = "(undef)";
 318     }
 319
 320     if (items > 1) {
 321         STRLEN len;
 322         SV *req = ST(1);
 323
 324         if (undef) {
 325              if (pkg)
 326                   Perl_croak(aTHX_
 327                              "%s does not define $%s::VERSION--version check failed",
 328                              HvNAME(pkg), HvNAME(pkg));
 329              else {
 330                   char *str = SvPVx(ST(0), len);
 331
 332                   Perl_croak(aTHX_
 333                              "%s defines neither package nor VERSION--version check failed", str);
 334              }
 335         }
 336         if (!SvNIOK(sv) && SvPOK(sv)) {
 337             char *str = SvPVx(sv,len);
 338             while (len) {
 339                 --len;
 340                 /* XXX could DWIM "1.2.3" here */
 341                 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
 342                     break;
 343             }
 344             if (len) {
 345                 if (SvNOK(req) && SvPOK(req)) {
 346                     /* they said C<use Foo v1.2.3> and $Foo::VERSION
 347                      * doesn't look like a float: do string compare */
 348                     if (sv_cmp(req,sv) == 1) {
 349                         Perl_croak(aTHX_ "%s v%"VDf" required--"
 350                                    "this is only v%"VDf,
 351                                    HvNAME(pkg), req, sv);
 352                     }
 353                     goto finish;
 354                 }
 355                 /* they said C<use Foo 1.002_003> and $Foo::VERSION
 356                  * doesn't look like a float: force numeric compare */
 357                 (void)SvUPGRADE(sv, SVt_PVNV);
 358                 SvNVX(sv) = str_to_version(sv);
 359                 SvPOK_off(sv);
 360                 SvNOK_on(sv);
 361             }
 362         }
 363         /* if we get here, we're looking for a numeric comparison,
 364          * so force the required version into a float, even if they
 365          * said C<use Foo v1.2.3> */
 366         if (SvNOK(req) && SvPOK(req)) {
 367             NV n = SvNV(req);
 368             req = sv_newmortal();
 369             sv_setnv(req, n);
 370         }
 371
 372         if (SvNV(req) > SvNV(sv))
 373             Perl_croak(aTHX_ "%s version %s required--this is only version %s",
 374                        HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
 375     }
 376
 377 finish:
 378     ST(0) = sv;
 379
 380     XSRETURN(1);
 381 }
 382
 383 XS(XS_version_new)
 384 {
 385     dXSARGS;
 386     if (items != 2)
 387         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 388     SP -= items;
 389     {
 390 /*      char *  class = (char *)SvPV_nolen(ST(0)); */
 391         SV *    version = ST(1);
 392
 393 {
 394     PUSHs(new_version(version));
 395 }
 396
 397         PUTBACK;
 398         return;
 399     }
 400 }
 401
 402 XS(XS_version_stringify)
 403 {
 404     dXSARGS;
 405     if (items < 1)
 406         Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
 407     SP -= items;
 408     {
 409         SV *    lobj;
 410
 411         if (sv_derived_from(ST(0), "version")) {
 412                 SV *tmp = SvRV(ST(0));
 413                 lobj = tmp;
 414         }
 415         else
 416                 Perl_croak(aTHX_ "lobj is not of type version");
 417
 418 {
 419     SV  *vs = NEWSV(92,5);
 420     if ( lobj == SvRV(PL_patchlevel) )
 421         sv_catsv(vs,lobj);
 422     else
 423         vstringify(vs,lobj);
 424     PUSHs(vs);
 425 }
 426
 427         PUTBACK;
 428         return;
 429     }
 430 }
 431
 432 XS(XS_version_numify)
 433 {
 434     dXSARGS;
 435     if (items < 1)
 436         Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
 437     SP -= items;
 438     {
 439         SV *    lobj;
 440
 441         if (sv_derived_from(ST(0), "version")) {
 442                 SV *tmp = SvRV(ST(0));
 443                 lobj = tmp;
 444         }
 445         else
 446                 Perl_croak(aTHX_ "lobj is not of type version");
 447
 448 {
 449     SV  *vs = NEWSV(92,5);
 450     vnumify(vs,lobj);
 451     PUSHs(vs);
 452 }
 453
 454         PUTBACK;
 455         return;
 456     }
 457 }
 458
 459 XS(XS_version_vcmp)
 460 {
 461     dXSARGS;
 462     if (items < 1)
 463         Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 464     SP -= items;
 465     {
 466         SV *    lobj;
 467
 468         if (sv_derived_from(ST(0), "version")) {
 469                 SV *tmp = SvRV(ST(0));
 470                 lobj = tmp;
 471         }
 472         else
 473                 Perl_croak(aTHX_ "lobj is not of type version");
 474
 475 {
 476     SV  *rs;
 477     SV  *rvs;
 478     SV * robj = ST(1);
 479     IV   swap = (IV)SvIV(ST(2));
 480
 481     if ( ! sv_derived_from(robj, "version") )
 482     {
 483         robj = new_version(robj);
 484     }
 485     rvs = SvRV(robj);
 486
 487     if ( swap )
 488     {
 489         rs = newSViv(sv_cmp(rvs,lobj));
 490     }
 491     else
 492     {
 493         rs = newSViv(sv_cmp(lobj,rvs));
 494     }
 495
 496     PUSHs(rs);
 497 }
 498
 499         PUTBACK;
 500         return;
 501     }
 502 }
 503
 504 XS(XS_version_boolean)
 505 {
 506     dXSARGS;
 507     if (items < 1)
 508         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 509     SP -= items;
 510     {
 511         SV *    lobj;
 512
 513         if (sv_derived_from(ST(0), "version")) {
 514                 SV *tmp = SvRV(ST(0));
 515                 lobj = tmp;
 516         }
 517         else
 518                 Perl_croak(aTHX_ "lobj is not of type version");
 519
 520 {
 521     SV  *rs;
 522     rs = newSViv(sv_cmp(lobj,Nullsv));
 523     PUSHs(rs);
 524 }
 525
 526         PUTBACK;
 527         return;
 528     }
 529 }
 530
 531 XS(XS_version_noop)
 532 {
 533     dXSARGS;
 534     if (items < 1)
 535         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 536     {
 537         SV *    lobj;
 538
 539         if (sv_derived_from(ST(0), "version")) {
 540                 SV *tmp = SvRV(ST(0));
 541                 lobj = tmp;
 542         }
 543         else
 544                 Perl_croak(aTHX_ "lobj is not of type version");
 545
 546 {
 547     Perl_croak(aTHX_ "operation not supported with version object");
 548 }
 549
 550     }
 551     XSRETURN_EMPTY;
 552 }
 553
 554 XS(XS_utf8_valid)
 555 {
 556     dXSARGS;
 557     if (items != 1)
 558         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 559     {
 560         SV *    sv = ST(0);
 561  {
 562   STRLEN len;
 563   char *s = SvPV(sv,len);
 564   if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
 565    XSRETURN_YES;
 566   else
 567    XSRETURN_NO;
 568  }
 569     }
 570     XSRETURN_EMPTY;
 571 }
 572
 573 XS(XS_utf8_encode)
 574 {
 575     dXSARGS;
 576     if (items != 1)
 577         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 578     {
 579         SV *    sv = ST(0);
 580
 581         sv_utf8_encode(sv);
 582     }
 583     XSRETURN_EMPTY;
 584 }
 585
 586 XS(XS_utf8_decode)
 587 {
 588     dXSARGS;
 589     if (items != 1)
 590         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 591     {
 592         SV *    sv = ST(0);
 593         bool    RETVAL;
 594
 595         RETVAL = sv_utf8_decode(sv);
 596         ST(0) = boolSV(RETVAL);
 597         sv_2mortal(ST(0));
 598     }
 599     XSRETURN(1);
 600 }
 601
 602 XS(XS_utf8_upgrade)
 603 {
 604     dXSARGS;
 605     if (items != 1)
 606         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 607     {
 608         SV *    sv = ST(0);
 609         STRLEN  RETVAL;
 610         dXSTARG;
 611
 612         RETVAL = sv_utf8_upgrade(sv);
 613         XSprePUSH; PUSHi((IV)RETVAL);
 614     }
 615     XSRETURN(1);
 616 }
 617
 618 XS(XS_utf8_downgrade)
 619 {
 620     dXSARGS;
 621     if (items < 1 || items > 2)
 622         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 623     {
 624         SV *    sv = ST(0);
 625         bool    failok;
 626         bool    RETVAL;
 627
 628         if (items < 2)
 629             failok = 0;
 630         else {
 631             failok = (int)SvIV(ST(1));
 632         }
 633
 634         RETVAL = sv_utf8_downgrade(sv, failok);
 635         ST(0) = boolSV(RETVAL);
 636         sv_2mortal(ST(0));
 637     }
 638     XSRETURN(1);
 639 }
 640
 641 XS(XS_utf8_native_to_unicode)
 642 {
 643  dXSARGS;
 644  UV uv = SvUV(ST(0));
 645
 646  if (items > 1)
 647      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 648
 649  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 650  XSRETURN(1);
 651 }
 652
 653 XS(XS_utf8_unicode_to_native)
 654 {
 655  dXSARGS;
 656  UV uv = SvUV(ST(0));
 657
 658  if (items > 1)
 659      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 660
 661  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 662  XSRETURN(1);
 663 }
 664
 665 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 666 {
 667     dXSARGS;
 668     SV *sv = SvRV(ST(0));
 669     if (items == 1) {
 670          if (SvREADONLY(sv))
 671              XSRETURN_YES;
 672          else
 673              XSRETURN_NO;
 674     }
 675     else if (items == 2) {
 676         if (SvTRUE(ST(1))) {
 677             SvREADONLY_on(sv);
 678             XSRETURN_YES;
 679         }
 680         else {
 681             /* I hope you really know what you are doing. */
 682             SvREADONLY_off(sv);
 683             XSRETURN_NO;
 684         }
 685     }
 686     XSRETURN_UNDEF; /* Can't happen. */
 687 }
 688
 689 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 690 {
 691     dXSARGS;
 692     SV *sv = SvRV(ST(0));
 693     if (items == 1)
 694          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 695     else if (items == 2) {
 696          /* I hope you really know what you are doing. */
 697          SvREFCNT(sv) = SvIV(ST(1));
 698          XSRETURN_IV(SvREFCNT(sv));
 699     }
 700     XSRETURN_UNDEF; /* Can't happen. */
 701 }
 702
 703 /* Maybe this should return the number of placeholders found in scalar context,
 704    and a list of them in list context.  */
 705 XS(XS_Internals_hv_clear_placehold)
 706 {
 707     dXSARGS;
 708     HV *hv = (HV *) SvRV(ST(0));
 709
 710     /* I don't care how many parameters were passed in, but I want to avoid
 711        the unused variable warning. */
 712
 713     items = (I32)HvPLACEHOLDERS(hv);
 714
 715     if (items) {
 716         HE *entry;
 717         I32 riter = HvRITER(hv);
 718         HE *eiter = HvEITER(hv);
 719         hv_iterinit(hv);
 720         /* This may look suboptimal with the items *after* the iternext, but
 721            it's quite deliberate. We only get here with items==0 if we've
 722            just deleted the last placeholder in the hash. If we've just done
 723            that then it means that the hash is in lazy delete mode, and the
 724            HE is now only referenced in our iterator. If we just quit the loop
 725            and discarded our iterator then the HE leaks. So we do the && the
 726            other way to ensure iternext is called just one more time, which
 727            has the side effect of triggering the lazy delete.  */
 728         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
 729             && items) {
 730             SV *val = hv_iterval(hv, entry);
 731
 732             if (val == &PL_sv_undef) {
 733
 734                 /* It seems that I have to go back in the front of the hash
 735                    API to delete a hash, even though I have a HE structure
 736                    pointing to the very entry I want to delete, and could hold
 737                    onto the previous HE that points to it. And it's easier to
 738                    go in with SVs as I can then specify the precomputed hash,
 739                    and don't have fun and games with utf8 keys.  */
 740                 SV *key = hv_iterkeysv(entry);
 741
 742                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
 743                 items--;
 744             }
 745         }
 746         HvRITER(hv) = riter;
 747         HvEITER(hv) = eiter;
 748     }
 749
 750     XSRETURN(0);
 751 }