universal.c

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