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