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