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