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