universal.c

   1 /*    universal.c
   2  *
   3  *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4  *    2005, 2006, 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 /* This file contains the code that implements the functions in Perl's
  18  * UNIVERSAL package, such as UNIVERSAL->can().
  19  */
  20
  21 #include "EXTERN.h"
  22 #define PERL_IN_UNIVERSAL_C
  23 #include "perl.h"
  24
  25 #ifdef USE_PERLIO
  26 #include "perliol.h" /* For the PERLIO_F_XXX */
  27 #endif
  28
  29 /*
  30  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  31  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  32  */
  33
  34 STATIC SV *
  35 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
  36              int len, int level)
  37 {
  38     AV* av;
  39     GV* gv;
  40     GV** gvp;
  41     HV* hv = NULL;
  42     SV* subgen = NULL;
  43     const char *hvname;
  44
  45     /* A stash/class can go by many names (ie. User == main::User), so
  46        we compare the stash itself just in case */
  47     if (name_stash && (stash == name_stash))
  48         return &PL_sv_yes;
  49
  50     hvname = HvNAME_get(stash);
  51
  52     if (strEQ(hvname, name))
  53         return &PL_sv_yes;
  54
  55     if (strEQ(name, "UNIVERSAL"))
  56         return &PL_sv_yes;
  57
  58     if (level > 100)
  59         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
  60                    hvname);
  61
  62     gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
  63
  64     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
  65         && (hv = GvHV(gv)))
  66     {
  67         if (SvIV(subgen) == (IV)PL_sub_generation) {
  68             SV* sv;
  69             SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
  70             if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
  71                 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
  72                                   name, hvname) );
  73                 return sv;
  74             }
  75         }
  76         else {
  77             DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
  78                               hvname) );
  79             hv_clear(hv);
  80             sv_setiv(subgen, PL_sub_generation);
  81         }
  82     }
  83
  84     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
  85
  86     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
  87         if (!hv || !subgen) {
  88             gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
  89
  90             gv = *gvp;
  91
  92             if (SvTYPE(gv) != SVt_PVGV)
  93                 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
  94
  95             if (!hv)
  96                 hv = GvHVn(gv);
  97             if (!subgen) {
  98                 subgen = newSViv(PL_sub_generation);
  99                 GvSV(gv) = subgen;
 100             }
 101         }
 102         if (hv) {
 103             SV** svp = AvARRAY(av);
 104             /* NOTE: No support for tied ISA */
 105             I32 items = AvFILLp(av) + 1;
 106             while (items--) {
 107                 SV* const sv = *svp++;
 108                 HV* const basestash = gv_stashsv(sv, FALSE);
 109                 if (!basestash) {
 110                     if (ckWARN(WARN_MISC))
 111                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 112                                     "Can't locate package %"SVf" for @%s::ISA",
 113                                     sv, hvname);
 114                     continue;
 115                 }
 116                 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
 117                                              len, level + 1)) {
 118                     (void)hv_store(hv,name,len,&PL_sv_yes,0);
 119                     return &PL_sv_yes;
 120                 }
 121             }
 122             (void)hv_store(hv,name,len,&PL_sv_no,0);
 123         }
 124     }
 125     return &PL_sv_no;
 126 }
 127
 128 /*
 129 =head1 SV Manipulation Functions
 130
 131 =for apidoc sv_derived_from
 132
 133 Returns a boolean indicating whether the SV is derived from the specified
 134 class.  This is the function that implements C<UNIVERSAL::isa>.  It works
 135 for class names as well as for objects.
 136
 137 =cut
 138 */
 139
 140 bool
 141 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 142 {
 143     HV *stash;
 144
 145     SvGETMAGIC(sv);
 146
 147     if (SvROK(sv)) {
 148         const char *type;
 149         sv = SvRV(sv);
 150         type = sv_reftype(sv,0);
 151         if (type && strEQ(type,name))
 152             return TRUE;
 153         stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
 154     }
 155     else {
 156         stash = gv_stashsv(sv, FALSE);
 157     }
 158
 159     if (stash) {
 160         HV * const name_stash = gv_stashpv(name, FALSE);
 161         return isa_lookup(stash, name, name_stash, strlen(name), 0) == &PL_sv_yes;
 162     }
 163     else
 164         return FALSE;
 165
 166 }
 167
 168 #include "XSUB.h"
 169
 170 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
 171 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
 172 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
 173 XS(XS_utf8_is_utf8);
 174 XS(XS_utf8_valid);
 175 XS(XS_utf8_encode);
 176 XS(XS_utf8_decode);
 177 XS(XS_utf8_upgrade);
 178 XS(XS_utf8_downgrade);
 179 XS(XS_utf8_unicode_to_native);
 180 XS(XS_utf8_native_to_unicode);
 181 XS(XS_Internals_SvREADONLY);
 182 XS(XS_Internals_SvREFCNT);
 183 XS(XS_Internals_hv_clear_placehold);
 184 XS(XS_PerlIO_get_layers);
 185 XS(XS_Regexp_DESTROY);
 186 XS(XS_Internals_hash_seed);
 187 XS(XS_Internals_rehash_seed);
 188 XS(XS_Internals_HvREHASH);
 189
 190 void
 191 Perl_boot_core_UNIVERSAL(pTHX)
 192 {
 193     const char file[] = __FILE__;
 194
 195     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         (char *)file);
 196     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         (char *)file);
 197     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     (char *)file);
 198     newXS("utf8::is_utf8", XS_utf8_is_utf8, (char *)file);
 199     newXS("utf8::valid", XS_utf8_valid, (char *)file);
 200     newXS("utf8::encode", XS_utf8_encode, (char *)file);
 201     newXS("utf8::decode", XS_utf8_decode, (char *)file);
 202     newXS("utf8::upgrade", XS_utf8_upgrade, (char *)file);
 203     newXS("utf8::downgrade", XS_utf8_downgrade, (char *)file);
 204     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, (char *)file);
 205     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, (char *)file);
 206     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, (char *)file, "\\[$%@];$");
 207     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, (char *)file, "\\[$%@];$");
 208     newXSproto("Internals::hv_clear_placeholders",
 209                XS_Internals_hv_clear_placehold, (char *)file, "\\%");
 210     newXSproto("PerlIO::get_layers",
 211                XS_PerlIO_get_layers, (char *)file, "*;@");
 212     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, (char *)file);
 213     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, (char *)file, "");
 214     newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, (char *)file, "");
 215     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, (char *)file, "\\%");
 216 }
 217
 218
 219 XS(XS_UNIVERSAL_isa)
 220 {
 221     dXSARGS;
 222
 223     if (items != 2)
 224         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 225     else {
 226         SV * const sv = ST(0);
 227         const char *name;
 228
 229         SvGETMAGIC(sv);
 230
 231         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 232                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 233             XSRETURN_UNDEF;
 234
 235         name = SvPV_nolen_const(ST(1));
 236
 237         ST(0) = boolSV(sv_derived_from(sv, name));
 238         XSRETURN(1);
 239     }
 240 }
 241
 242 XS(XS_UNIVERSAL_can)
 243 {
 244     dXSARGS;
 245     SV   *sv;
 246     const char *name;
 247     SV   *rv;
 248     HV   *pkg = NULL;
 249
 250     if (items != 2)
 251         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 252
 253     sv = ST(0);
 254
 255     SvGETMAGIC(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 = SvPV_nolen_const(ST(1));
 262     rv = &PL_sv_undef;
 263
 264     if (SvROK(sv)) {
 265         sv = (SV*)SvRV(sv);
 266         if (SvOBJECT(sv))
 267             pkg = SvSTASH(sv);
 268     }
 269     else {
 270         pkg = gv_stashsv(sv, FALSE);
 271     }
 272
 273     if (pkg) {
 274         GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 275         if (gv && isGV(gv))
 276             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 277     }
 278
 279     ST(0) = rv;
 280     XSRETURN(1);
 281 }
 282
 283 XS(XS_UNIVERSAL_VERSION)
 284 {
 285     dXSARGS;
 286     HV *pkg;
 287     GV **gvp;
 288     GV *gv;
 289     SV *sv;
 290     const char *undef;
 291
 292     if (SvROK(ST(0))) {
 293         sv = (SV*)SvRV(ST(0));
 294         if (!SvOBJECT(sv))
 295             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 296         pkg = SvSTASH(sv);
 297     }
 298     else {
 299         pkg = gv_stashsv(ST(0), FALSE);
 300     }
 301
 302     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : NULL;
 303
 304     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 305         SV * const nsv = sv_newmortal();
 306         sv_setsv(nsv, sv);
 307         sv = nsv;
 308         undef = NULL;
 309     }
 310     else {
 311         sv = (SV*)&PL_sv_undef;
 312         undef = "(undef)";
 313     }
 314
 315     if (items > 1) {
 316         SV *req = ST(1);
 317
 318         if (undef) {
 319             if (pkg) {
 320                 const char * const name = HvNAME_get(pkg);
 321                 Perl_croak(aTHX_
 322                              "%s does not define $%s::VERSION--version check failed",
 323                              name, name);
 324             } else {
 325                 Perl_croak(aTHX_
 326                              "%s defines neither package nor VERSION--version check failed",
 327                              SvPVx_nolen_const(ST(0)) );
 328              }
 329         }
 330         if (!SvNIOK(sv) && SvPOK(sv)) {
 331             STRLEN len;
 332             const char *const str = SvPV_const(sv,len);
 333             while (len) {
 334                 --len;
 335                 /* XXX could DWIM "1.2.3" here */
 336                 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
 337                     break;
 338             }
 339             if (len) {
 340                 if (SvNOK(req) && SvPOK(req)) {
 341                     /* they said C<use Foo v1.2.3> and $Foo::VERSION
 342                      * doesn't look like a float: do string compare */
 343                     if (sv_cmp(req,sv) == 1) {
 344                         Perl_croak(aTHX_ "%s v%"VDf" required--"
 345                                    "this is only v%"VDf,
 346                                    HvNAME(pkg), req, sv);
 347                     }
 348                     goto finish;
 349                 }
 350                 /* they said C<use Foo 1.002_003> and $Foo::VERSION
 351                  * doesn't look like a float: force numeric compare */
 352                 (void)SvUPGRADE(sv, SVt_PVNV);
 353                 SvNVX(sv) = str_to_version(sv);
 354                 SvPOK_off(sv);
 355                 SvNOK_on(sv);
 356             }
 357         }
 358         /* if we get here, we're looking for a numeric comparison,
 359          * so force the required version into a float, even if they
 360          * said C<use Foo v1.2.3> */
 361         if (SvNOK(req) && SvPOK(req)) {
 362             NV n = SvNV(req);
 363             req = sv_newmortal();
 364             sv_setnv(req, n);
 365         }
 366
 367         if (SvNV(req) > SvNV(sv))
 368             Perl_croak(aTHX_ "%s version %s required--this is only version %s",
 369                        HvNAME_get(pkg), SvPV_nolen(req), SvPV_nolen(sv));
 370     }
 371
 372 finish:
 373     ST(0) = sv;
 374
 375     XSRETURN(1);
 376 }
 377
 378 XS(XS_utf8_is_utf8)
 379 {
 380      dXSARGS;
 381      if (items != 1)
 382           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
 383      else {
 384         const SV * const sv = ST(0);
 385             if (SvUTF8(sv))
 386                 XSRETURN_YES;
 387             else
 388                 XSRETURN_NO;
 389      }
 390      XSRETURN_EMPTY;
 391 }
 392
 393 XS(XS_utf8_valid)
 394 {
 395      dXSARGS;
 396      if (items != 1)
 397           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 398     else {
 399         SV * const sv = ST(0);
 400         STRLEN len;
 401         const char * const s = SvPV_const(sv,len);
 402         if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
 403             XSRETURN_YES;
 404         else
 405             XSRETURN_NO;
 406     }
 407      XSRETURN_EMPTY;
 408 }
 409
 410 XS(XS_utf8_encode)
 411 {
 412     dXSARGS;
 413     if (items != 1)
 414         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 415     sv_utf8_encode(ST(0));
 416     XSRETURN_EMPTY;
 417 }
 418
 419 XS(XS_utf8_decode)
 420 {
 421     dXSARGS;
 422     if (items != 1)
 423         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 424     else {
 425         SV * const sv = ST(0);
 426         const bool RETVAL = sv_utf8_decode(sv);
 427         ST(0) = boolSV(RETVAL);
 428         sv_2mortal(ST(0));
 429     }
 430     XSRETURN(1);
 431 }
 432
 433 XS(XS_utf8_upgrade)
 434 {
 435     dXSARGS;
 436     if (items != 1)
 437         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 438     else {
 439         SV * const sv = ST(0);
 440         STRLEN  RETVAL;
 441         dXSTARG;
 442
 443         RETVAL = sv_utf8_upgrade(sv);
 444         XSprePUSH; PUSHi((IV)RETVAL);
 445     }
 446     XSRETURN(1);
 447 }
 448
 449 XS(XS_utf8_downgrade)
 450 {
 451     dXSARGS;
 452     if (items < 1 || items > 2)
 453         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 454     else {
 455         SV * const sv = ST(0);
 456         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 457         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 458
 459         ST(0) = boolSV(RETVAL);
 460         sv_2mortal(ST(0));
 461     }
 462     XSRETURN(1);
 463 }
 464
 465 XS(XS_utf8_native_to_unicode)
 466 {
 467  dXSARGS;
 468  const UV uv = SvUV(ST(0));
 469
 470  if (items > 1)
 471      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 472
 473  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 474  XSRETURN(1);
 475 }
 476
 477 XS(XS_utf8_unicode_to_native)
 478 {
 479  dXSARGS;
 480  const UV uv = SvUV(ST(0));
 481
 482  if (items > 1)
 483      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 484
 485  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 486  XSRETURN(1);
 487 }
 488
 489 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 490 {
 491     dXSARGS;
 492     SV * const sv = SvRV(ST(0));
 493
 494     if (items == 1) {
 495          if (SvREADONLY(sv))
 496              XSRETURN_YES;
 497          else
 498              XSRETURN_NO;
 499     }
 500     else if (items == 2) {
 501         if (SvTRUE(ST(1))) {
 502             SvREADONLY_on(sv);
 503             XSRETURN_YES;
 504         }
 505         else {
 506             /* I hope you really know what you are doing. */
 507             SvREADONLY_off(sv);
 508             XSRETURN_NO;
 509         }
 510     }
 511     XSRETURN_UNDEF; /* Can't happen. */
 512 }
 513
 514 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 515 {
 516     dXSARGS;
 517     SV * const sv = SvRV(ST(0));
 518
 519     if (items == 1)
 520          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 521     else if (items == 2) {
 522          /* I hope you really know what you are doing. */
 523          SvREFCNT(sv) = SvIV(ST(1));
 524          XSRETURN_IV(SvREFCNT(sv));
 525     }
 526     XSRETURN_UNDEF; /* Can't happen. */
 527 }
 528
 529 XS(XS_Internals_hv_clear_placehold)
 530 {
 531     dXSARGS;
 532
 533     if (items != 1)
 534         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
 535     else {
 536         HV * const hv = (HV *) SvRV(ST(0));
 537         hv_clear_placeholders(hv);
 538         XSRETURN(0);
 539     }
 540 }
 541
 542 XS(XS_Regexp_DESTROY)
 543 {
 544     PERL_UNUSED_ARG(cv);
 545 }
 546
 547 XS(XS_PerlIO_get_layers)
 548 {
 549     dXSARGS;
 550     if (items < 1 || items % 2 == 0)
 551         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
 552 #ifdef USE_PERLIO
 553     {
 554         SV *    sv;
 555         GV *    gv;
 556         IO *    io;
 557         bool    input = TRUE;
 558         bool    details = FALSE;
 559
 560         if (items > 1) {
 561              SV * const *svp;
 562              for (svp = MARK + 2; svp <= SP; svp += 2) {
 563                   SV * const * const varp = svp;
 564                   SV * const * const valp = svp + 1;
 565                   STRLEN klen;
 566                   const char * const key = SvPV_const(*varp, klen);
 567
 568                   switch (*key) {
 569                   case 'i':
 570                        if (klen == 5 && memEQ(key, "input", 5)) {
 571                             input = SvTRUE(*valp);
 572                             break;
 573                        }
 574                        goto fail;
 575                   case 'o':
 576                        if (klen == 6 && memEQ(key, "output", 6)) {
 577                             input = !SvTRUE(*valp);
 578                             break;
 579                        }
 580                        goto fail;
 581                   case 'd':
 582                        if (klen == 7 && memEQ(key, "details", 7)) {
 583                             details = SvTRUE(*valp);
 584                             break;
 585                        }
 586                        goto fail;
 587                   default:
 588                   fail:
 589                        Perl_croak(aTHX_
 590                                   "get_layers: unknown argument '%s'",
 591                                   key);
 592                   }
 593              }
 594
 595              SP -= (items - 1);
 596         }
 597
 598         sv = POPs;
 599         gv = (GV*)sv;
 600
 601         if (!isGV(sv)) {
 602              if (SvROK(sv) && isGV(SvRV(sv)))
 603                   gv = (GV*)SvRV(sv);
 604              else if (SvPOKp(sv))
 605                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
 606         }
 607
 608         if (gv && (io = GvIO(gv))) {
 609              dTARGET;
 610              AV* const av = PerlIO_get_layers(aTHX_ input ?
 611                                         IoIFP(io) : IoOFP(io));
 612              I32 i;
 613              const I32 last = av_len(av);
 614              I32 nitem = 0;
 615
 616              for (i = last; i >= 0; i -= 3) {
 617                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 618                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 619                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 620
 621                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 622                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 623                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 624
 625                   if (details) {
 626                        XPUSHs(namok
 627                               ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
 628                               : &PL_sv_undef);
 629                        XPUSHs(argok
 630                               ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
 631                               : &PL_sv_undef);
 632                        if (flgok)
 633                             XPUSHi(SvIVX(*flgsvp));
 634                        else
 635                             XPUSHs(&PL_sv_undef);
 636                        nitem += 3;
 637                   }
 638                   else {
 639                        if (namok && argok)
 640                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 641                                                *namsvp, *argsvp));
 642                        else if (namok)
 643                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
 644                        else
 645                             XPUSHs(&PL_sv_undef);
 646                        nitem++;
 647                        if (flgok) {
 648                             const IV flags = SvIVX(*flgsvp);
 649
 650                             if (flags & PERLIO_F_UTF8) {
 651                                  XPUSHs(newSVpvn("utf8", 4));
 652                                  nitem++;
 653                             }
 654                        }
 655                   }
 656              }
 657
 658              SvREFCNT_dec(av);
 659
 660              XSRETURN(nitem);
 661         }
 662     }
 663 #endif
 664
 665     XSRETURN(0);
 666 }
 667
 668 XS(XS_Internals_hash_seed)
 669 {
 670     /* Using dXSARGS would also have dITEM and dSP,
 671      * which define 2 unused local variables.  */
 672     dAXMARK;
 673     PERL_UNUSED_ARG(cv);
 674     PERL_UNUSED_VAR(mark);
 675     XSRETURN_UV(PERL_HASH_SEED);
 676 }
 677
 678 XS(XS_Internals_rehash_seed)
 679 {
 680     /* Using dXSARGS would also have dITEM and dSP,
 681      * which define 2 unused local variables.  */
 682     dAXMARK;
 683     PERL_UNUSED_ARG(cv);
 684     PERL_UNUSED_VAR(mark);
 685     XSRETURN_UV(PL_rehash_seed);
 686 }
 687
 688 XS(XS_Internals_HvREHASH)       /* Subject to change  */
 689 {
 690     dXSARGS;
 691     if (SvROK(ST(0))) {
 692         const HV * const hv = (HV *) SvRV(ST(0));
 693         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
 694             if (HvREHASH(hv))
 695                 XSRETURN_YES;
 696             else
 697                 XSRETURN_NO;
 698         }
 699     }
 700     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
 701 }
 702
 703 /*
 704  * Local variables:
 705  * c-indentation-style: bsd
 706  * c-basic-offset: 4
 707  * indent-tabs-mode: t
 708  * End:
 709  *
 710  * ex: set ts=8 sts=4 sw=4 noet:
 711  */