universal.c

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