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 XS(XS_Internals_hv_clear_placehold)
 736 {
 737     dXSARGS;
 738     HV *hv = (HV *) SvRV(ST(0));
 739     if (items != 1)
 740         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
 741     hv_clear_placeholders(hv);
 742     XSRETURN(0);
 743 }
 744
 745 XS(XS_Regexp_DESTROY)
 746 {
 747
 748 }
 749
 750 XS(XS_PerlIO_get_layers)
 751 {
 752     dXSARGS;
 753     if (items < 1 || items % 2 == 0)
 754         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
 755 #ifdef USE_PERLIO
 756     {
 757         SV *    sv;
 758         GV *    gv;
 759         IO *    io;
 760         bool    input = TRUE;
 761         bool    details = FALSE;
 762
 763         if (items > 1) {
 764              SV **svp;
 765
 766              for (svp = MARK + 2; svp <= SP; svp += 2) {
 767                   SV **varp = svp;
 768                   SV **valp = svp + 1;
 769                   STRLEN klen;
 770                   char *key = SvPV(*varp, klen);
 771
 772                   switch (*key) {
 773                   case 'i':
 774                        if (klen == 5 && memEQ(key, "input", 5)) {
 775                             input = SvTRUE(*valp);
 776                             break;
 777                        }
 778                        goto fail;
 779                   case 'o':
 780                        if (klen == 6 && memEQ(key, "output", 6)) {
 781                             input = !SvTRUE(*valp);
 782                             break;
 783                        }
 784                        goto fail;
 785                   case 'd':
 786                        if (klen == 7 && memEQ(key, "details", 7)) {
 787                             details = SvTRUE(*valp);
 788                             break;
 789                        }
 790                        goto fail;
 791                   default:
 792                   fail:
 793                        Perl_croak(aTHX_
 794                                   "get_layers: unknown argument '%s'",
 795                                   key);
 796                   }
 797              }
 798
 799              SP -= (items - 1);
 800         }
 801
 802         sv = POPs;
 803         gv = (GV*)sv;
 804
 805         if (!isGV(sv)) {
 806              if (SvROK(sv) && isGV(SvRV(sv)))
 807                   gv = (GV*)SvRV(sv);
 808              else
 809                   gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
 810         }
 811
 812         if (gv && (io = GvIO(gv))) {
 813              dTARGET;
 814              AV* av = PerlIO_get_layers(aTHX_ input ?
 815                                         IoIFP(io) : IoOFP(io));
 816              I32 i;
 817              I32 last = av_len(av);
 818              I32 nitem = 0;
 819
 820              for (i = last; i >= 0; i -= 3) {
 821                   SV **namsvp;
 822                   SV **argsvp;
 823                   SV **flgsvp;
 824                   bool namok, argok, flgok;
 825
 826                   namsvp = av_fetch(av, i - 2, FALSE);
 827                   argsvp = av_fetch(av, i - 1, FALSE);
 828                   flgsvp = av_fetch(av, i,     FALSE);
 829
 830                   namok = namsvp && *namsvp && SvPOK(*namsvp);
 831                   argok = argsvp && *argsvp && SvPOK(*argsvp);
 832                   flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 833
 834                   if (details) {
 835                        XPUSHs(namok ?
 836                              newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
 837                        XPUSHs(argok ?
 838                              newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
 839                        if (flgok)
 840                             XPUSHi(SvIVX(*flgsvp));
 841                        else
 842                             XPUSHs(&PL_sv_undef);
 843                        nitem += 3;
 844                   }
 845                   else {
 846                        if (namok && argok)
 847                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 848                                                *namsvp, *argsvp));
 849                        else if (namok)
 850                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
 851                        else
 852                             XPUSHs(&PL_sv_undef);
 853                        nitem++;
 854                        if (flgok) {
 855                             IV flags = SvIVX(*flgsvp);
 856
 857                             if (flags & PERLIO_F_UTF8) {
 858                                  XPUSHs(newSVpvn("utf8", 4));
 859                                  nitem++;
 860                             }
 861                        }
 862                   }
 863              }
 864
 865              SvREFCNT_dec(av);
 866
 867              XSRETURN(nitem);
 868         }
 869     }
 870 #endif
 871
 872     XSRETURN(0);
 873 }
 874
 875 XS(XS_Internals_hash_seed)
 876 {
 877     /* Using dXSARGS would also have dITEM and dSP,
 878      * which define 2 unused local variables.  */
 879     dMARK; dAX;
 880     XSRETURN_UV(PERL_HASH_SEED);
 881 }
 882
 883 XS(XS_Internals_rehash_seed)
 884 {
 885     /* Using dXSARGS would also have dITEM and dSP,
 886      * which define 2 unused local variables.  */
 887     dMARK; dAX;
 888     XSRETURN_UV(PL_rehash_seed);
 889 }
 890
 891 XS(XS_Internals_HvREHASH)       /* Subject to change  */
 892 {
 893     dXSARGS;
 894     if (SvROK(ST(0))) {
 895         HV *hv = (HV *) SvRV(ST(0));
 896         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
 897             if (HvREHASH(hv))
 898                 XSRETURN_YES;
 899             else
 900                 XSRETURN_NO;
 901         }
 902     }
 903     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
 904 }