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