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