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