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     dVAR;
  39     AV* av;
  40     GV* gv;
  41     GV** gvp;
  42     HV* hv = NULL;
  43     SV* subgen = NULL;
  44     const char *hvname;
  45
  46     /* A stash/class can go by many names (ie. User == main::User), so
  47        we compare the stash itself just in case */
  48     if (name_stash && ((const HV *)stash == name_stash))
  49         return TRUE;
  50
  51     hvname = HvNAME_get(stash);
  52
  53     if (strEQ(hvname, name))
  54         return TRUE;
  55
  56     if (strEQ(name, "UNIVERSAL"))
  57         return TRUE;
  58
  59     if (level > 100)
  60         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
  61                    hvname);
  62
  63     gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE);
  64
  65     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
  66         && (hv = GvHV(gv)))
  67     {
  68         if (SvIV(subgen) == (IV)PL_sub_generation) {
  69             SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
  70             if (svp) {
  71                 SV * const sv = *svp;
  72                 if (sv != &PL_sv_undef)
  73                     DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
  74                                     name, hvname) );
  75                 return (sv == &PL_sv_yes);
  76             }
  77         }
  78         else {
  79             DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
  80                               hvname) );
  81             hv_clear(hv);
  82             sv_setiv(subgen, PL_sub_generation);
  83         }
  84     }
  85
  86     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
  87
  88     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
  89         if (!hv || !subgen) {
  90             gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE);
  91
  92             gv = *gvp;
  93
  94             if (SvTYPE(gv) != SVt_PVGV)
  95                 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
  96
  97             if (!hv)
  98                 hv = GvHVn(gv);
  99             if (!subgen) {
 100                 subgen = newSViv(PL_sub_generation);
 101                 GvSV(gv) = subgen;
 102             }
 103         }
 104         if (hv) {
 105             SV** svp = AvARRAY(av);
 106             /* NOTE: No support for tied ISA */
 107             I32 items = AvFILLp(av) + 1;
 108             while (items--) {
 109                 SV* const sv = *svp++;
 110                 HV* const basestash = gv_stashsv(sv, FALSE);
 111                 if (!basestash) {
 112                     if (ckWARN(WARN_MISC))
 113                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 114                                     "Can't locate package %"SVf" for @%s::ISA",
 115                                     (void*)sv, hvname);
 116                     continue;
 117                 }
 118                 if (isa_lookup(basestash, name, name_stash, len, level + 1)) {
 119                     (void)hv_store(hv,name,len,&PL_sv_yes,0);
 120                     return TRUE;
 121                 }
 122             }
 123             (void)hv_store(hv,name,len,&PL_sv_no,0);
 124         }
 125     }
 126     return FALSE;
 127 }
 128
 129 /*
 130 =head1 SV Manipulation Functions
 131
 132 =for apidoc sv_derived_from
 133
 134 Returns a boolean indicating whether the SV is derived from the specified class
 135 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
 136 normal Perl method.
 137
 138 =cut
 139 */
 140
 141 bool
 142 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 143 {
 144     dVAR;
 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 /*
 171 =for apidoc sv_does
 172
 173 Returns a boolean indicating whether the SV performs a specific, named role.
 174 The SV can be a Perl object or the name of a Perl class.
 175
 176 =cut
 177 */
 178
 179 #include "XSUB.h"
 180
 181 bool
 182 Perl_sv_does(pTHX_ SV *sv, const char *name)
 183 {
 184     const char *classname;
 185     bool does_it;
 186
 187     dSP;
 188     ENTER;
 189     SAVETMPS;
 190
 191     SvGETMAGIC(sv);
 192
 193     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 194                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 195         return FALSE;
 196
 197     if (sv_isobject(sv)) {
 198         classname = sv_reftype(SvRV(sv),TRUE);
 199     } else {
 200         classname = SvPV(sv,PL_na);
 201     }
 202
 203     if (strEQ(name,classname))
 204         return TRUE;
 205
 206     PUSHMARK(SP);
 207     XPUSHs(sv);
 208     XPUSHs(sv_2mortal(newSVpv(name, 0)));
 209     PUTBACK;
 210
 211     call_method("isa", G_SCALAR);
 212     SPAGAIN;
 213
 214     does_it = SvTRUE( TOPs );
 215     FREETMPS;
 216     LEAVE;
 217
 218     return does_it;
 219 }
 220
 221 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
 222 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
 223 PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
 224 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
 225 XS(XS_version_new);
 226 XS(XS_version_stringify);
 227 XS(XS_version_numify);
 228 XS(XS_version_normal);
 229 XS(XS_version_vcmp);
 230 XS(XS_version_boolean);
 231 #ifdef HASATTRIBUTE_NORETURN
 232 XS(XS_version_noop) __attribute__noreturn__;
 233 #else
 234 XS(XS_version_noop);
 235 #endif
 236 XS(XS_version_is_alpha);
 237 XS(XS_version_qv);
 238 XS(XS_utf8_is_utf8);
 239 XS(XS_utf8_valid);
 240 XS(XS_utf8_encode);
 241 XS(XS_utf8_decode);
 242 XS(XS_utf8_upgrade);
 243 XS(XS_utf8_downgrade);
 244 XS(XS_utf8_unicode_to_native);
 245 XS(XS_utf8_native_to_unicode);
 246 XS(XS_Internals_SvREADONLY);
 247 XS(XS_Internals_SvREFCNT);
 248 XS(XS_Internals_hv_clear_placehold);
 249 XS(XS_PerlIO_get_layers);
 250 XS(XS_Regexp_DESTROY);
 251 XS(XS_Internals_hash_seed);
 252 XS(XS_Internals_rehash_seed);
 253 XS(XS_Internals_HvREHASH);
 254 XS(XS_Internals_inc_sub_generation);
 255
 256 void
 257 Perl_boot_core_UNIVERSAL(pTHX)
 258 {
 259     dVAR;
 260     static const char file[] = __FILE__;
 261
 262     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
 263     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
 264     newXS("UNIVERSAL::DOES",            XS_UNIVERSAL_DOES,        file);
 265     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
 266     {
 267         /* register the overloading (type 'A') magic */
 268         PL_amagic_generation++;
 269         /* Make it findable via fetchmethod */
 270         newXS("version::()", XS_version_noop, file);
 271         newXS("version::new", XS_version_new, file);
 272         newXS("version::(\"\"", XS_version_stringify, file);
 273         newXS("version::stringify", XS_version_stringify, file);
 274         newXS("version::(0+", XS_version_numify, file);
 275         newXS("version::numify", XS_version_numify, file);
 276         newXS("version::normal", XS_version_normal, file);
 277         newXS("version::(cmp", XS_version_vcmp, file);
 278         newXS("version::(<=>", XS_version_vcmp, file);
 279         newXS("version::vcmp", XS_version_vcmp, file);
 280         newXS("version::(bool", XS_version_boolean, file);
 281         newXS("version::boolean", XS_version_boolean, file);
 282         newXS("version::(nomethod", XS_version_noop, file);
 283         newXS("version::noop", XS_version_noop, file);
 284         newXS("version::is_alpha", XS_version_is_alpha, file);
 285         newXS("version::qv", XS_version_qv, file);
 286     }
 287     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
 288     newXS("utf8::valid", XS_utf8_valid, file);
 289     newXS("utf8::encode", XS_utf8_encode, file);
 290     newXS("utf8::decode", XS_utf8_decode, file);
 291     newXS("utf8::upgrade", XS_utf8_upgrade, file);
 292     newXS("utf8::downgrade", XS_utf8_downgrade, file);
 293     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
 294     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
 295     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
 296     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 297     newXSproto("Internals::hv_clear_placeholders",
 298                XS_Internals_hv_clear_placehold, file, "\\%");
 299     newXSproto("PerlIO::get_layers",
 300                XS_PerlIO_get_layers, file, "*;@");
 301     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
 302     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
 303     newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
 304     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
 305     newXSproto("Internals::inc_sub_generation",XS_Internals_inc_sub_generation,
 306                file, "");
 307 }
 308
 309
 310 XS(XS_UNIVERSAL_isa)
 311 {
 312     dVAR;
 313     dXSARGS;
 314
 315     if (items != 2)
 316         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 317     else {
 318         SV * const sv = ST(0);
 319         const char *name;
 320
 321         SvGETMAGIC(sv);
 322
 323         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 324                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 325             XSRETURN_UNDEF;
 326
 327         name = SvPV_nolen_const(ST(1));
 328
 329         ST(0) = boolSV(sv_derived_from(sv, name));
 330         XSRETURN(1);
 331     }
 332 }
 333
 334 XS(XS_UNIVERSAL_can)
 335 {
 336     dVAR;
 337     dXSARGS;
 338     SV   *sv;
 339     const char *name;
 340     SV   *rv;
 341     HV   *pkg = NULL;
 342
 343     if (items != 2)
 344         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 345
 346     sv = ST(0);
 347
 348     SvGETMAGIC(sv);
 349
 350     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 351                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 352         XSRETURN_UNDEF;
 353
 354     name = SvPV_nolen_const(ST(1));
 355     rv = &PL_sv_undef;
 356
 357     if (SvROK(sv)) {
 358         sv = (SV*)SvRV(sv);
 359         if (SvOBJECT(sv))
 360             pkg = SvSTASH(sv);
 361     }
 362     else {
 363         pkg = gv_stashsv(sv, FALSE);
 364     }
 365
 366     if (pkg) {
 367         GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 368         if (gv && isGV(gv))
 369             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 370     }
 371
 372     ST(0) = rv;
 373     XSRETURN(1);
 374 }
 375
 376 XS(XS_UNIVERSAL_DOES)
 377 {
 378     dVAR;
 379     dXSARGS;
 380
 381     if (items != 2)
 382         Perl_croak(aTHX_ "Usage: invocant->does(kind)");
 383     else {
 384         SV * const sv = ST(0);
 385         const char *name;
 386
 387         name = SvPV_nolen_const(ST(1));
 388         if (sv_does( sv, name ))
 389             XSRETURN_YES;
 390
 391         XSRETURN_NO;
 392     }
 393 }
 394
 395 XS(XS_UNIVERSAL_VERSION)
 396 {
 397     dVAR;
 398     dXSARGS;
 399     HV *pkg;
 400     GV **gvp;
 401     GV *gv;
 402     SV *sv;
 403     const char *undef;
 404
 405     if (SvROK(ST(0))) {
 406         sv = (SV*)SvRV(ST(0));
 407         if (!SvOBJECT(sv))
 408             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 409         pkg = SvSTASH(sv);
 410     }
 411     else {
 412         pkg = gv_stashsv(ST(0), FALSE);
 413     }
 414
 415     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
 416
 417     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 418         SV * const nsv = sv_newmortal();
 419         sv_setsv(nsv, sv);
 420         sv = nsv;
 421         if ( !sv_derived_from(sv, "version"))
 422             upg_version(sv);
 423         undef = NULL;
 424     }
 425     else {
 426         sv = (SV*)&PL_sv_undef;
 427         undef = "(undef)";
 428     }
 429
 430     if (items > 1) {
 431         SV *req = ST(1);
 432
 433         if (undef) {
 434             if (pkg) {
 435                 const char * const name = HvNAME_get(pkg);
 436                 Perl_croak(aTHX_
 437                            "%s does not define $%s::VERSION--version check failed",
 438                            name, name);
 439             } else {
 440                 Perl_croak(aTHX_
 441                              "%s defines neither package nor VERSION--version check failed",
 442                              SvPVx_nolen_const(ST(0)) );
 443              }
 444         }
 445
 446         if ( !sv_derived_from(req, "version")) {
 447             /* req may very well be R/O, so create a new object */
 448             SV * const nsv = sv_newmortal();
 449             sv_setsv(nsv, req);
 450             req = nsv;
 451             upg_version(req);
 452         }
 453
 454         if ( vcmp( req, sv ) > 0 )
 455             Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
 456                        "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg),
 457                        (void*)vnumify(req),
 458                        (void*)vnormal(req),
 459                        (void*)vnumify(sv),
 460                        (void*)vnormal(sv));
 461     }
 462
 463     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
 464         ST(0) = vnumify(sv);
 465     } else {
 466         ST(0) = sv;
 467     }
 468
 469     XSRETURN(1);
 470 }
 471
 472 XS(XS_version_new)
 473 {
 474     dVAR;
 475     dXSARGS;
 476     if (items > 3)
 477         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 478     SP -= items;
 479     {
 480         SV *vs = ST(1);
 481         SV *rv;
 482         const char * const classname =
 483             sv_isobject(ST(0)) /* get the class if called as an object method */
 484                 ? HvNAME(SvSTASH(SvRV(ST(0))))
 485                 : (char *)SvPV_nolen(ST(0));
 486
 487         if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
 488             /* create empty object */
 489             vs = sv_newmortal();
 490             sv_setpvn(vs,"",0);
 491         }
 492         else if ( items == 3 ) {
 493             vs = sv_newmortal();
 494             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 495         }
 496
 497         rv = new_version(vs);
 498         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
 499             sv_bless(rv, gv_stashpv(classname,TRUE));
 500
 501         PUSHs(sv_2mortal(rv));
 502         PUTBACK;
 503         return;
 504     }
 505 }
 506
 507 XS(XS_version_stringify)
 508 {
 509      dVAR;
 510      dXSARGS;
 511      if (items < 1)
 512           Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
 513      SP -= items;
 514      {
 515           SV *  lobj;
 516
 517           if (sv_derived_from(ST(0), "version")) {
 518                lobj = SvRV(ST(0));
 519           }
 520           else
 521                Perl_croak(aTHX_ "lobj is not of type version");
 522
 523           PUSHs(sv_2mortal(vstringify(lobj)));
 524
 525           PUTBACK;
 526           return;
 527      }
 528 }
 529
 530 XS(XS_version_numify)
 531 {
 532      dVAR;
 533      dXSARGS;
 534      if (items < 1)
 535           Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
 536      SP -= items;
 537      {
 538           SV *  lobj;
 539
 540           if (sv_derived_from(ST(0), "version")) {
 541                lobj = SvRV(ST(0));
 542           }
 543           else
 544                Perl_croak(aTHX_ "lobj is not of type version");
 545
 546           PUSHs(sv_2mortal(vnumify(lobj)));
 547
 548           PUTBACK;
 549           return;
 550      }
 551 }
 552
 553 XS(XS_version_normal)
 554 {
 555      dVAR;
 556      dXSARGS;
 557      if (items < 1)
 558           Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
 559      SP -= items;
 560      {
 561           SV *  lobj;
 562
 563           if (sv_derived_from(ST(0), "version")) {
 564                lobj = SvRV(ST(0));
 565           }
 566           else
 567                Perl_croak(aTHX_ "lobj is not of type version");
 568
 569           PUSHs(sv_2mortal(vnormal(lobj)));
 570
 571           PUTBACK;
 572           return;
 573      }
 574 }
 575
 576 XS(XS_version_vcmp)
 577 {
 578      dVAR;
 579      dXSARGS;
 580      if (items < 1)
 581           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 582      SP -= items;
 583      {
 584           SV *  lobj;
 585
 586           if (sv_derived_from(ST(0), "version")) {
 587                lobj = SvRV(ST(0));
 588           }
 589           else
 590                Perl_croak(aTHX_ "lobj is not of type version");
 591
 592           {
 593                SV       *rs;
 594                SV       *rvs;
 595                SV * robj = ST(1);
 596                const IV  swap = (IV)SvIV(ST(2));
 597
 598                if ( ! sv_derived_from(robj, "version") )
 599                {
 600                     robj = new_version(robj);
 601                }
 602                rvs = SvRV(robj);
 603
 604                if ( swap )
 605                {
 606                     rs = newSViv(vcmp(rvs,lobj));
 607                }
 608                else
 609                {
 610                     rs = newSViv(vcmp(lobj,rvs));
 611                }
 612
 613                PUSHs(sv_2mortal(rs));
 614           }
 615
 616           PUTBACK;
 617           return;
 618      }
 619 }
 620
 621 XS(XS_version_boolean)
 622 {
 623     dVAR;
 624     dXSARGS;
 625     if (items < 1)
 626         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 627     SP -= items;
 628     if (sv_derived_from(ST(0), "version")) {
 629         SV * const lobj = SvRV(ST(0));
 630         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
 631         PUSHs(sv_2mortal(rs));
 632         PUTBACK;
 633         return;
 634     }
 635     else
 636         Perl_croak(aTHX_ "lobj is not of type version");
 637 }
 638
 639 XS(XS_version_noop)
 640 {
 641     dVAR;
 642     dXSARGS;
 643     if (items < 1)
 644         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 645     if (sv_derived_from(ST(0), "version"))
 646         Perl_croak(aTHX_ "operation not supported with version object");
 647     else
 648         Perl_croak(aTHX_ "lobj is not of type version");
 649 #ifndef HASATTRIBUTE_NORETURN
 650     XSRETURN_EMPTY;
 651 #endif
 652 }
 653
 654 XS(XS_version_is_alpha)
 655 {
 656     dVAR;
 657     dXSARGS;
 658     if (items != 1)
 659         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
 660     SP -= items;
 661     if (sv_derived_from(ST(0), "version")) {
 662         SV * const lobj = ST(0);
 663         if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
 664             XSRETURN_YES;
 665         else
 666             XSRETURN_NO;
 667         PUTBACK;
 668         return;
 669     }
 670     else
 671         Perl_croak(aTHX_ "lobj is not of type version");
 672 }
 673
 674 XS(XS_version_qv)
 675 {
 676     dVAR;
 677     dXSARGS;
 678     if (items != 1)
 679         Perl_croak(aTHX_ "Usage: version::qv(ver)");
 680     SP -= items;
 681     {
 682         SV *    ver = ST(0);
 683         if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
 684             SV * const vs = sv_newmortal();
 685             char *version;
 686             if ( SvNOK(ver) ) /* may get too much accuracy */
 687             {
 688                 char tbuf[64];
 689                 const STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver));
 690                 version = savepvn(tbuf, len);
 691             }
 692             else
 693             {
 694                 version = savesvpv(ver);
 695             }
 696             (void)scan_version(version,vs,TRUE);
 697             Safefree(version);
 698
 699             PUSHs(vs);
 700         }
 701         else
 702         {
 703             PUSHs(sv_2mortal(new_version(ver)));
 704         }
 705
 706         PUTBACK;
 707         return;
 708     }
 709 }
 710
 711 XS(XS_utf8_is_utf8)
 712 {
 713      dVAR;
 714      dXSARGS;
 715      if (items != 1)
 716           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
 717      else {
 718         const SV * const sv = ST(0);
 719             if (SvUTF8(sv))
 720                 XSRETURN_YES;
 721             else
 722                 XSRETURN_NO;
 723      }
 724      XSRETURN_EMPTY;
 725 }
 726
 727 XS(XS_utf8_valid)
 728 {
 729      dVAR;
 730      dXSARGS;
 731      if (items != 1)
 732           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 733     else {
 734         SV * const sv = ST(0);
 735         STRLEN len;
 736         const char * const s = SvPV_const(sv,len);
 737         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 738             XSRETURN_YES;
 739         else
 740             XSRETURN_NO;
 741     }
 742      XSRETURN_EMPTY;
 743 }
 744
 745 XS(XS_utf8_encode)
 746 {
 747     dVAR;
 748     dXSARGS;
 749     if (items != 1)
 750         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 751     sv_utf8_encode(ST(0));
 752     XSRETURN_EMPTY;
 753 }
 754
 755 XS(XS_utf8_decode)
 756 {
 757     dVAR;
 758     dXSARGS;
 759     if (items != 1)
 760         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 761     else {
 762         SV * const sv = ST(0);
 763         const bool RETVAL = sv_utf8_decode(sv);
 764         ST(0) = boolSV(RETVAL);
 765         sv_2mortal(ST(0));
 766     }
 767     XSRETURN(1);
 768 }
 769
 770 XS(XS_utf8_upgrade)
 771 {
 772     dVAR;
 773     dXSARGS;
 774     if (items != 1)
 775         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 776     else {
 777         SV * const sv = ST(0);
 778         STRLEN  RETVAL;
 779         dXSTARG;
 780
 781         RETVAL = sv_utf8_upgrade(sv);
 782         XSprePUSH; PUSHi((IV)RETVAL);
 783     }
 784     XSRETURN(1);
 785 }
 786
 787 XS(XS_utf8_downgrade)
 788 {
 789     dVAR;
 790     dXSARGS;
 791     if (items < 1 || items > 2)
 792         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 793     else {
 794         SV * const sv = ST(0);
 795         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 796         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 797
 798         ST(0) = boolSV(RETVAL);
 799         sv_2mortal(ST(0));
 800     }
 801     XSRETURN(1);
 802 }
 803
 804 XS(XS_utf8_native_to_unicode)
 805 {
 806  dVAR;
 807  dXSARGS;
 808  const UV uv = SvUV(ST(0));
 809
 810  if (items > 1)
 811      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 812
 813  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 814  XSRETURN(1);
 815 }
 816
 817 XS(XS_utf8_unicode_to_native)
 818 {
 819  dVAR;
 820  dXSARGS;
 821  const UV uv = SvUV(ST(0));
 822
 823  if (items > 1)
 824      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 825
 826  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 827  XSRETURN(1);
 828 }
 829
 830 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 831 {
 832     dVAR;
 833     dXSARGS;
 834     SV * const sv = SvRV(ST(0));
 835
 836     if (items == 1) {
 837          if (SvREADONLY(sv))
 838              XSRETURN_YES;
 839          else
 840              XSRETURN_NO;
 841     }
 842     else if (items == 2) {
 843         if (SvTRUE(ST(1))) {
 844             SvREADONLY_on(sv);
 845             XSRETURN_YES;
 846         }
 847         else {
 848             /* I hope you really know what you are doing. */
 849             SvREADONLY_off(sv);
 850             XSRETURN_NO;
 851         }
 852     }
 853     XSRETURN_UNDEF; /* Can't happen. */
 854 }
 855
 856 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 857 {
 858     dVAR;
 859     dXSARGS;
 860     SV * const sv = SvRV(ST(0));
 861
 862     if (items == 1)
 863          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 864     else if (items == 2) {
 865          /* I hope you really know what you are doing. */
 866          SvREFCNT(sv) = SvIV(ST(1));
 867          XSRETURN_IV(SvREFCNT(sv));
 868     }
 869     XSRETURN_UNDEF; /* Can't happen. */
 870 }
 871
 872 XS(XS_Internals_hv_clear_placehold)
 873 {
 874     dVAR;
 875     dXSARGS;
 876
 877     if (items != 1)
 878         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
 879     else {
 880         HV * const hv = (HV *) SvRV(ST(0));
 881         hv_clear_placeholders(hv);
 882         XSRETURN(0);
 883     }
 884 }
 885
 886 XS(XS_Regexp_DESTROY)
 887 {
 888     PERL_UNUSED_CONTEXT;
 889     PERL_UNUSED_ARG(cv);
 890 }
 891
 892 XS(XS_PerlIO_get_layers)
 893 {
 894     dVAR;
 895     dXSARGS;
 896     if (items < 1 || items % 2 == 0)
 897         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
 898 #ifdef USE_PERLIO
 899     {
 900         SV *    sv;
 901         GV *    gv;
 902         IO *    io;
 903         bool    input = TRUE;
 904         bool    details = FALSE;
 905
 906         if (items > 1) {
 907              SV * const *svp;
 908              for (svp = MARK + 2; svp <= SP; svp += 2) {
 909                   SV * const * const varp = svp;
 910                   SV * const * const valp = svp + 1;
 911                   STRLEN klen;
 912                   const char * const key = SvPV_const(*varp, klen);
 913
 914                   switch (*key) {
 915                   case 'i':
 916                        if (klen == 5 && memEQ(key, "input", 5)) {
 917                             input = SvTRUE(*valp);
 918                             break;
 919                        }
 920                        goto fail;
 921                   case 'o':
 922                        if (klen == 6 && memEQ(key, "output", 6)) {
 923                             input = !SvTRUE(*valp);
 924                             break;
 925                        }
 926                        goto fail;
 927                   case 'd':
 928                        if (klen == 7 && memEQ(key, "details", 7)) {
 929                             details = SvTRUE(*valp);
 930                             break;
 931                        }
 932                        goto fail;
 933                   default:
 934                   fail:
 935                        Perl_croak(aTHX_
 936                                   "get_layers: unknown argument '%s'",
 937                                   key);
 938                   }
 939              }
 940
 941              SP -= (items - 1);
 942         }
 943
 944         sv = POPs;
 945         gv = (GV*)sv;
 946
 947         if (!isGV(sv)) {
 948              if (SvROK(sv) && isGV(SvRV(sv)))
 949                   gv = (GV*)SvRV(sv);
 950              else if (SvPOKp(sv))
 951                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
 952         }
 953
 954         if (gv && (io = GvIO(gv))) {
 955              dTARGET;
 956              AV* const av = PerlIO_get_layers(aTHX_ input ?
 957                                         IoIFP(io) : IoOFP(io));
 958              I32 i;
 959              const I32 last = av_len(av);
 960              I32 nitem = 0;
 961
 962              for (i = last; i >= 0; i -= 3) {
 963                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 964                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 965                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 966
 967                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 968                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 969                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 970
 971                   if (details) {
 972                        XPUSHs(namok
 973                               ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
 974                               : &PL_sv_undef);
 975                        XPUSHs(argok
 976                               ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
 977                               : &PL_sv_undef);
 978                        if (flgok)
 979                             XPUSHi(SvIVX(*flgsvp));
 980                        else
 981                             XPUSHs(&PL_sv_undef);
 982                        nitem += 3;
 983                   }
 984                   else {
 985                        if (namok && argok)
 986                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 987                                                  (void*)*namsvp,
 988                                                  (void*)*argsvp));
 989                        else if (namok)
 990                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf,
 991                                                  (void*)*namsvp));
 992                        else
 993                             XPUSHs(&PL_sv_undef);
 994                        nitem++;
 995                        if (flgok) {
 996                             const IV flags = SvIVX(*flgsvp);
 997
 998                             if (flags & PERLIO_F_UTF8) {
 999                                  XPUSHs(newSVpvs("utf8"));
1000                                  nitem++;
1001                             }
1002                        }
1003                   }
1004              }
1005
1006              SvREFCNT_dec(av);
1007
1008              XSRETURN(nitem);
1009         }
1010     }
1011 #endif
1012
1013     XSRETURN(0);
1014 }
1015
1016 XS(XS_Internals_hash_seed)
1017 {
1018     dVAR;
1019     /* Using dXSARGS would also have dITEM and dSP,
1020      * which define 2 unused local variables.  */
1021     dAXMARK;
1022     PERL_UNUSED_ARG(cv);
1023     PERL_UNUSED_VAR(mark);
1024     XSRETURN_UV(PERL_HASH_SEED);
1025 }
1026
1027 XS(XS_Internals_rehash_seed)
1028 {
1029     dVAR;
1030     /* Using dXSARGS would also have dITEM and dSP,
1031      * which define 2 unused local variables.  */
1032     dAXMARK;
1033     PERL_UNUSED_ARG(cv);
1034     PERL_UNUSED_VAR(mark);
1035     XSRETURN_UV(PL_rehash_seed);
1036 }
1037
1038 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1039 {
1040     dVAR;
1041     dXSARGS;
1042     if (SvROK(ST(0))) {
1043         const HV * const hv = (HV *) SvRV(ST(0));
1044         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1045             if (HvREHASH(hv))
1046                 XSRETURN_YES;
1047             else
1048                 XSRETURN_NO;
1049         }
1050     }
1051     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1052 }
1053
1054 XS(XS_Internals_inc_sub_generation)
1055 {
1056     dVAR;
1057     /* Using dXSARGS would also have dITEM and dSP,
1058      * which define 2 unused local variables.  */
1059     dAXMARK;
1060     PERL_UNUSED_ARG(cv);
1061     PERL_UNUSED_VAR(mark);
1062     ++PL_sub_generation;
1063     XSRETURN_EMPTY;
1064 }
1065
1066 /*
1067  * Local variables:
1068  * c-indentation-style: bsd
1069  * c-basic-offset: 4
1070  * indent-tabs-mode: t
1071  * End:
1072  *
1073  * ex: set ts=8 sts=4 sw=4 noet:
1074  */