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