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