universal.c

   1 /*    universal.c
   2  *
   3  *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4  *    2005, 2006, 2007 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 * const name, const HV* const name_stash)
  36 {
  37     dVAR;
  38     AV* stash_linear_isa;
  39     SV** svp;
  40     const char *hvname;
  41     I32 items;
  42
  43     /* A stash/class can go by many names (ie. User == main::User), so
  44        we compare the stash itself just in case */
  45     if (name_stash && ((const HV *)stash == name_stash))
  46         return TRUE;
  47
  48     hvname = HvNAME_get(stash);
  49
  50     if (strEQ(hvname, name))
  51         return TRUE;
  52
  53     if (strEQ(name, "UNIVERSAL"))
  54         return TRUE;
  55
  56     stash_linear_isa = mro_get_linear_isa(stash);
  57     svp = AvARRAY(stash_linear_isa) + 1;
  58     items = AvFILLp(stash_linear_isa);
  59     while (items--) {
  60         SV* const basename_sv = *svp++;
  61         HV* const basestash = gv_stashsv(basename_sv, 0);
  62         if (!basestash) {
  63             if (ckWARN(WARN_SYNTAX))
  64                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
  65                             "Can't locate package %"SVf" for the parents of %s",
  66                             SVfARG(basename_sv), hvname);
  67             continue;
  68         }
  69         if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
  70             return TRUE;
  71     }
  72
  73     return FALSE;
  74 }
  75
  76 /*
  77 =head1 SV Manipulation Functions
  78
  79 =for apidoc sv_derived_from
  80
  81 Returns a boolean indicating whether the SV is derived from the specified class
  82 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
  83 normal Perl method.
  84
  85 =cut
  86 */
  87
  88 bool
  89 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
  90 {
  91     dVAR;
  92     HV *stash;
  93
  94     SvGETMAGIC(sv);
  95
  96     if (SvROK(sv)) {
  97         const char *type;
  98         sv = SvRV(sv);
  99         type = sv_reftype(sv,0);
 100         if (type && strEQ(type,name))
 101             return TRUE;
 102         stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
 103     }
 104     else {
 105         stash = gv_stashsv(sv, 0);
 106     }
 107
 108     if (stash) {
 109         HV * const name_stash = gv_stashpv(name, 0);
 110         return isa_lookup(stash, name, name_stash);
 111     }
 112     else
 113         return FALSE;
 114
 115 }
 116
 117 /*
 118 =for apidoc sv_does
 119
 120 Returns a boolean indicating whether the SV performs a specific, named role.
 121 The SV can be a Perl object or the name of a Perl class.
 122
 123 =cut
 124 */
 125
 126 #include "XSUB.h"
 127
 128 bool
 129 Perl_sv_does(pTHX_ SV *sv, const char *name)
 130 {
 131     const char *classname;
 132     bool does_it;
 133     SV *methodname;
 134
 135     dSP;
 136     ENTER;
 137     SAVETMPS;
 138
 139     SvGETMAGIC(sv);
 140
 141     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 142                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 143         return FALSE;
 144
 145     if (sv_isobject(sv)) {
 146         classname = sv_reftype(SvRV(sv),TRUE);
 147     } else {
 148         classname = SvPV_nolen(sv);
 149     }
 150
 151     if (strEQ(name,classname))
 152         return TRUE;
 153
 154     PUSHMARK(SP);
 155     XPUSHs(sv);
 156     XPUSHs(sv_2mortal(newSVpv(name, 0)));
 157     PUTBACK;
 158
 159     methodname = sv_2mortal(newSVpv("isa", 0));
 160     /* ugly hack: use the SvSCREAM flag so S_method_common
 161      * can figure out we're calling DOES() and not isa(),
 162      * and report eventual errors correctly. --rgs */
 163     SvSCREAM_on(methodname);
 164     call_sv(methodname, G_SCALAR | G_METHOD);
 165     SPAGAIN;
 166
 167     does_it = SvTRUE( TOPs );
 168     FREETMPS;
 169     LEAVE;
 170
 171     return does_it;
 172 }
 173
 174 regexp *
 175 Perl_get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) {
 176     MAGIC *mg;
 177     if (sv) {
 178         if (SvMAGICAL(sv))
 179             mg_get(sv);
 180         if (SvROK(sv) &&
 181             (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
 182             SvTYPE(sv) == SVt_PVMG &&
 183             (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
 184         {
 185             if (mgp) *mgp = mg;
 186             return (regexp *)mg->mg_obj;
 187         }
 188     }
 189     if (mgp) *mgp = NULL;
 190     return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL);
 191 }
 192
 193
 194 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
 195 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
 196 PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
 197 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
 198 XS(XS_version_new);
 199 XS(XS_version_stringify);
 200 XS(XS_version_numify);
 201 XS(XS_version_normal);
 202 XS(XS_version_vcmp);
 203 XS(XS_version_boolean);
 204 #ifdef HASATTRIBUTE_NORETURN
 205 XS(XS_version_noop) __attribute__noreturn__;
 206 #else
 207 XS(XS_version_noop);
 208 #endif
 209 XS(XS_version_is_alpha);
 210 XS(XS_version_qv);
 211 XS(XS_utf8_is_utf8);
 212 XS(XS_utf8_valid);
 213 XS(XS_utf8_encode);
 214 XS(XS_utf8_decode);
 215 XS(XS_utf8_upgrade);
 216 XS(XS_utf8_downgrade);
 217 XS(XS_utf8_unicode_to_native);
 218 XS(XS_utf8_native_to_unicode);
 219 XS(XS_Internals_SvREADONLY);
 220 XS(XS_Internals_SvREFCNT);
 221 XS(XS_Internals_hv_clear_placehold);
 222 XS(XS_PerlIO_get_layers);
 223 XS(XS_Regexp_DESTROY);
 224 XS(XS_Internals_hash_seed);
 225 XS(XS_Internals_rehash_seed);
 226 XS(XS_Internals_HvREHASH);
 227 XS(XS_Internals_inc_sub_generation);
 228 XS(XS_re_is_regexp);
 229 XS(XS_re_regname);
 230 XS(XS_re_regnames);
 231 XS(XS_re_regnames_iterinit);
 232 XS(XS_re_regnames_iternext);
 233 XS(XS_re_regnames_count);
 234
 235 void
 236 Perl_boot_core_UNIVERSAL(pTHX)
 237 {
 238     dVAR;
 239     static const char file[] = __FILE__;
 240
 241     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
 242     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
 243     newXS("UNIVERSAL::DOES",            XS_UNIVERSAL_DOES,        file);
 244     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
 245     {
 246         /* register the overloading (type 'A') magic */
 247         PL_amagic_generation++;
 248         /* Make it findable via fetchmethod */
 249         newXS("version::()", XS_version_noop, file);
 250         newXS("version::new", XS_version_new, file);
 251         newXS("version::(\"\"", XS_version_stringify, file);
 252         newXS("version::stringify", XS_version_stringify, file);
 253         newXS("version::(0+", XS_version_numify, file);
 254         newXS("version::numify", XS_version_numify, file);
 255         newXS("version::normal", XS_version_normal, file);
 256         newXS("version::(cmp", XS_version_vcmp, file);
 257         newXS("version::(<=>", XS_version_vcmp, file);
 258         newXS("version::vcmp", XS_version_vcmp, file);
 259         newXS("version::(bool", XS_version_boolean, file);
 260         newXS("version::boolean", XS_version_boolean, file);
 261         newXS("version::(nomethod", XS_version_noop, file);
 262         newXS("version::noop", XS_version_noop, file);
 263         newXS("version::is_alpha", XS_version_is_alpha, file);
 264         newXS("version::qv", XS_version_qv, file);
 265     }
 266     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
 267     newXS("utf8::valid", XS_utf8_valid, file);
 268     newXS("utf8::encode", XS_utf8_encode, file);
 269     newXS("utf8::decode", XS_utf8_decode, file);
 270     newXS("utf8::upgrade", XS_utf8_upgrade, file);
 271     newXS("utf8::downgrade", XS_utf8_downgrade, file);
 272     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
 273     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
 274     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
 275     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 276     newXSproto("Internals::hv_clear_placeholders",
 277                XS_Internals_hv_clear_placehold, file, "\\%");
 278     newXSproto("PerlIO::get_layers",
 279                XS_PerlIO_get_layers, file, "*;@");
 280     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
 281     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
 282     newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
 283     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
 284     newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
 285     newXSproto("re::regname", XS_re_regname, file, ";$$");
 286     newXSproto("re::regnames", XS_re_regnames, file, ";$");
 287     newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, "");
 288     newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$");
 289     newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
 290 }
 291
 292
 293 XS(XS_UNIVERSAL_isa)
 294 {
 295     dVAR;
 296     dXSARGS;
 297     PERL_UNUSED_ARG(cv);
 298
 299     if (items != 2)
 300         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 301     else {
 302         SV * const sv = ST(0);
 303         const char *name;
 304
 305         SvGETMAGIC(sv);
 306
 307         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 308                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 309             XSRETURN_UNDEF;
 310
 311         name = SvPV_nolen_const(ST(1));
 312
 313         ST(0) = boolSV(sv_derived_from(sv, name));
 314         XSRETURN(1);
 315     }
 316 }
 317
 318 XS(XS_UNIVERSAL_can)
 319 {
 320     dVAR;
 321     dXSARGS;
 322     SV   *sv;
 323     const char *name;
 324     SV   *rv;
 325     HV   *pkg = NULL;
 326     PERL_UNUSED_ARG(cv);
 327
 328     if (items != 2)
 329         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 330
 331     sv = ST(0);
 332
 333     SvGETMAGIC(sv);
 334
 335     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 336                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 337         XSRETURN_UNDEF;
 338
 339     name = SvPV_nolen_const(ST(1));
 340     rv = &PL_sv_undef;
 341
 342     if (SvROK(sv)) {
 343         sv = (SV*)SvRV(sv);
 344         if (SvOBJECT(sv))
 345             pkg = SvSTASH(sv);
 346     }
 347     else {
 348         pkg = gv_stashsv(sv, 0);
 349     }
 350
 351     if (pkg) {
 352         GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 353         if (gv && isGV(gv))
 354             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 355     }
 356
 357     ST(0) = rv;
 358     XSRETURN(1);
 359 }
 360
 361 XS(XS_UNIVERSAL_DOES)
 362 {
 363     dVAR;
 364     dXSARGS;
 365     PERL_UNUSED_ARG(cv);
 366
 367     if (items != 2)
 368         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
 369     else {
 370         SV * const sv = ST(0);
 371         const char *name;
 372
 373         name = SvPV_nolen_const(ST(1));
 374         if (sv_does( sv, name ))
 375             XSRETURN_YES;
 376
 377         XSRETURN_NO;
 378     }
 379 }
 380
 381 XS(XS_UNIVERSAL_VERSION)
 382 {
 383     dVAR;
 384     dXSARGS;
 385     HV *pkg;
 386     GV **gvp;
 387     GV *gv;
 388     SV *sv;
 389     const char *undef;
 390     PERL_UNUSED_ARG(cv);
 391
 392     if (SvROK(ST(0))) {
 393         sv = (SV*)SvRV(ST(0));
 394         if (!SvOBJECT(sv))
 395             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 396         pkg = SvSTASH(sv);
 397     }
 398     else {
 399         pkg = gv_stashsv(ST(0), 0);
 400     }
 401
 402     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
 403
 404     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 405         SV * const nsv = sv_newmortal();
 406         sv_setsv(nsv, sv);
 407         sv = nsv;
 408         if ( !sv_derived_from(sv, "version"))
 409             upg_version(sv, FALSE);
 410         undef = NULL;
 411     }
 412     else {
 413         sv = (SV*)&PL_sv_undef;
 414         undef = "(undef)";
 415     }
 416
 417     if (items > 1) {
 418         SV *req = ST(1);
 419
 420         if (undef) {
 421             if (pkg) {
 422                 const char * const name = HvNAME_get(pkg);
 423                 Perl_croak(aTHX_
 424                            "%s does not define $%s::VERSION--version check failed",
 425                            name, name);
 426             } else {
 427                 Perl_croak(aTHX_
 428                              "%s defines neither package nor VERSION--version check failed",
 429                              SvPVx_nolen_const(ST(0)) );
 430              }
 431         }
 432
 433         if ( !sv_derived_from(req, "version")) {
 434             /* req may very well be R/O, so create a new object */
 435             req = sv_2mortal( new_version(req) );
 436         }
 437
 438         if ( vcmp( req, sv ) > 0 ) {
 439             if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) {
 440                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 441                        "this is only version %"SVf"", HvNAME_get(pkg),
 442                        SVfARG(vnormal(req)),
 443                        SVfARG(vnormal(sv)));
 444             } else {
 445                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 446                        "this is only version %"SVf"", HvNAME_get(pkg),
 447                        SVfARG(vstringify(req)),
 448                        SVfARG(vstringify(sv)));
 449             }
 450         }
 451
 452     }
 453
 454     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
 455         ST(0) = vstringify(sv);
 456     } else {
 457         ST(0) = sv;
 458     }
 459
 460     XSRETURN(1);
 461 }
 462
 463 XS(XS_version_new)
 464 {
 465     dVAR;
 466     dXSARGS;
 467     PERL_UNUSED_ARG(cv);
 468     if (items > 3)
 469         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 470     SP -= items;
 471     {
 472         SV *vs = ST(1);
 473         SV *rv;
 474         const char * const classname =
 475             sv_isobject(ST(0)) /* get the class if called as an object method */
 476                 ? HvNAME(SvSTASH(SvRV(ST(0))))
 477                 : (char *)SvPV_nolen(ST(0));
 478
 479         if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
 480             /* create empty object */
 481             vs = sv_newmortal();
 482             sv_setpvn(vs,"",0);
 483         }
 484         else if ( items == 3 ) {
 485             vs = sv_newmortal();
 486             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 487         }
 488
 489         rv = new_version(vs);
 490         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
 491             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 492
 493         PUSHs(sv_2mortal(rv));
 494         PUTBACK;
 495         return;
 496     }
 497 }
 498
 499 XS(XS_version_stringify)
 500 {
 501      dVAR;
 502      dXSARGS;
 503      PERL_UNUSED_ARG(cv);
 504      if (items < 1)
 505           Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
 506      SP -= items;
 507      {
 508           SV *  lobj;
 509
 510           if (sv_derived_from(ST(0), "version")) {
 511                lobj = SvRV(ST(0));
 512           }
 513           else
 514                Perl_croak(aTHX_ "lobj is not of type version");
 515
 516           PUSHs(sv_2mortal(vstringify(lobj)));
 517
 518           PUTBACK;
 519           return;
 520      }
 521 }
 522
 523 XS(XS_version_numify)
 524 {
 525      dVAR;
 526      dXSARGS;
 527      PERL_UNUSED_ARG(cv);
 528      if (items < 1)
 529           Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
 530      SP -= items;
 531      {
 532           SV *  lobj;
 533
 534           if (sv_derived_from(ST(0), "version")) {
 535                lobj = SvRV(ST(0));
 536           }
 537           else
 538                Perl_croak(aTHX_ "lobj is not of type version");
 539
 540           PUSHs(sv_2mortal(vnumify(lobj)));
 541
 542           PUTBACK;
 543           return;
 544      }
 545 }
 546
 547 XS(XS_version_normal)
 548 {
 549      dVAR;
 550      dXSARGS;
 551      PERL_UNUSED_ARG(cv);
 552      if (items < 1)
 553           Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
 554      SP -= items;
 555      {
 556           SV *  lobj;
 557
 558           if (sv_derived_from(ST(0), "version")) {
 559                lobj = SvRV(ST(0));
 560           }
 561           else
 562                Perl_croak(aTHX_ "lobj is not of type version");
 563
 564           PUSHs(sv_2mortal(vnormal(lobj)));
 565
 566           PUTBACK;
 567           return;
 568      }
 569 }
 570
 571 XS(XS_version_vcmp)
 572 {
 573      dVAR;
 574      dXSARGS;
 575      PERL_UNUSED_ARG(cv);
 576      if (items < 1)
 577           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 578      SP -= items;
 579      {
 580           SV *  lobj;
 581
 582           if (sv_derived_from(ST(0), "version")) {
 583                lobj = SvRV(ST(0));
 584           }
 585           else
 586                Perl_croak(aTHX_ "lobj is not of type version");
 587
 588           {
 589                SV       *rs;
 590                SV       *rvs;
 591                SV * robj = ST(1);
 592                const IV  swap = (IV)SvIV(ST(2));
 593
 594                if ( ! sv_derived_from(robj, "version") )
 595                {
 596                     robj = new_version(robj);
 597                }
 598                rvs = SvRV(robj);
 599
 600                if ( swap )
 601                {
 602                     rs = newSViv(vcmp(rvs,lobj));
 603                }
 604                else
 605                {
 606                     rs = newSViv(vcmp(lobj,rvs));
 607                }
 608
 609                PUSHs(sv_2mortal(rs));
 610           }
 611
 612           PUTBACK;
 613           return;
 614      }
 615 }
 616
 617 XS(XS_version_boolean)
 618 {
 619     dVAR;
 620     dXSARGS;
 621     PERL_UNUSED_ARG(cv);
 622     if (items < 1)
 623         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 624     SP -= items;
 625     if (sv_derived_from(ST(0), "version")) {
 626         SV * const lobj = SvRV(ST(0));
 627         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
 628         PUSHs(sv_2mortal(rs));
 629         PUTBACK;
 630         return;
 631     }
 632     else
 633         Perl_croak(aTHX_ "lobj is not of type version");
 634 }
 635
 636 XS(XS_version_noop)
 637 {
 638     dVAR;
 639     dXSARGS;
 640     PERL_UNUSED_ARG(cv);
 641     if (items < 1)
 642         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 643     if (sv_derived_from(ST(0), "version"))
 644         Perl_croak(aTHX_ "operation not supported with version object");
 645     else
 646         Perl_croak(aTHX_ "lobj is not of type version");
 647 #ifndef HASATTRIBUTE_NORETURN
 648     XSRETURN_EMPTY;
 649 #endif
 650 }
 651
 652 XS(XS_version_is_alpha)
 653 {
 654     dVAR;
 655     dXSARGS;
 656     PERL_UNUSED_ARG(cv);
 657     if (items != 1)
 658         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
 659     SP -= items;
 660     if (sv_derived_from(ST(0), "version")) {
 661         SV * const lobj = ST(0);
 662         if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
 663             XSRETURN_YES;
 664         else
 665             XSRETURN_NO;
 666         PUTBACK;
 667         return;
 668     }
 669     else
 670         Perl_croak(aTHX_ "lobj is not of type version");
 671 }
 672
 673 XS(XS_version_qv)
 674 {
 675     dVAR;
 676     dXSARGS;
 677     PERL_UNUSED_ARG(cv);
 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 rv = sv_newmortal();
 685             sv_setsv(rv,ver); /* make a duplicate */
 686             upg_version(rv, TRUE);
 687             PUSHs(rv);
 688         }
 689         else
 690         {
 691             PUSHs(sv_2mortal(new_version(ver)));
 692         }
 693
 694         PUTBACK;
 695         return;
 696     }
 697 }
 698
 699 XS(XS_utf8_is_utf8)
 700 {
 701      dVAR;
 702      dXSARGS;
 703      PERL_UNUSED_ARG(cv);
 704      if (items != 1)
 705           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
 706      else {
 707         const SV * const sv = ST(0);
 708             if (SvUTF8(sv))
 709                 XSRETURN_YES;
 710             else
 711                 XSRETURN_NO;
 712      }
 713      XSRETURN_EMPTY;
 714 }
 715
 716 XS(XS_utf8_valid)
 717 {
 718      dVAR;
 719      dXSARGS;
 720      PERL_UNUSED_ARG(cv);
 721      if (items != 1)
 722           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 723     else {
 724         SV * const sv = ST(0);
 725         STRLEN len;
 726         const char * const s = SvPV_const(sv,len);
 727         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 728             XSRETURN_YES;
 729         else
 730             XSRETURN_NO;
 731     }
 732      XSRETURN_EMPTY;
 733 }
 734
 735 XS(XS_utf8_encode)
 736 {
 737     dVAR;
 738     dXSARGS;
 739     PERL_UNUSED_ARG(cv);
 740     if (items != 1)
 741         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 742     sv_utf8_encode(ST(0));
 743     XSRETURN_EMPTY;
 744 }
 745
 746 XS(XS_utf8_decode)
 747 {
 748     dVAR;
 749     dXSARGS;
 750     PERL_UNUSED_ARG(cv);
 751     if (items != 1)
 752         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 753     else {
 754         SV * const sv = ST(0);
 755         const bool RETVAL = sv_utf8_decode(sv);
 756         ST(0) = boolSV(RETVAL);
 757         sv_2mortal(ST(0));
 758     }
 759     XSRETURN(1);
 760 }
 761
 762 XS(XS_utf8_upgrade)
 763 {
 764     dVAR;
 765     dXSARGS;
 766     PERL_UNUSED_ARG(cv);
 767     if (items != 1)
 768         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 769     else {
 770         SV * const sv = ST(0);
 771         STRLEN  RETVAL;
 772         dXSTARG;
 773
 774         RETVAL = sv_utf8_upgrade(sv);
 775         XSprePUSH; PUSHi((IV)RETVAL);
 776     }
 777     XSRETURN(1);
 778 }
 779
 780 XS(XS_utf8_downgrade)
 781 {
 782     dVAR;
 783     dXSARGS;
 784     PERL_UNUSED_ARG(cv);
 785     if (items < 1 || items > 2)
 786         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 787     else {
 788         SV * const sv = ST(0);
 789         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 790         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 791
 792         ST(0) = boolSV(RETVAL);
 793         sv_2mortal(ST(0));
 794     }
 795     XSRETURN(1);
 796 }
 797
 798 XS(XS_utf8_native_to_unicode)
 799 {
 800  dVAR;
 801  dXSARGS;
 802  const UV uv = SvUV(ST(0));
 803  PERL_UNUSED_ARG(cv);
 804
 805  if (items > 1)
 806      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 807
 808  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 809  XSRETURN(1);
 810 }
 811
 812 XS(XS_utf8_unicode_to_native)
 813 {
 814  dVAR;
 815  dXSARGS;
 816  const UV uv = SvUV(ST(0));
 817  PERL_UNUSED_ARG(cv);
 818
 819  if (items > 1)
 820      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 821
 822  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 823  XSRETURN(1);
 824 }
 825
 826 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 827 {
 828     dVAR;
 829     dXSARGS;
 830     SV * const sv = SvRV(ST(0));
 831     PERL_UNUSED_ARG(cv);
 832
 833     if (items == 1) {
 834          if (SvREADONLY(sv))
 835              XSRETURN_YES;
 836          else
 837              XSRETURN_NO;
 838     }
 839     else if (items == 2) {
 840         if (SvTRUE(ST(1))) {
 841             SvREADONLY_on(sv);
 842             XSRETURN_YES;
 843         }
 844         else {
 845             /* I hope you really know what you are doing. */
 846             SvREADONLY_off(sv);
 847             XSRETURN_NO;
 848         }
 849     }
 850     XSRETURN_UNDEF; /* Can't happen. */
 851 }
 852
 853 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 854 {
 855     dVAR;
 856     dXSARGS;
 857     SV * const sv = SvRV(ST(0));
 858     PERL_UNUSED_ARG(cv);
 859
 860     if (items == 1)
 861          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 862     else if (items == 2) {
 863          /* I hope you really know what you are doing. */
 864          SvREFCNT(sv) = SvIV(ST(1));
 865          XSRETURN_IV(SvREFCNT(sv));
 866     }
 867     XSRETURN_UNDEF; /* Can't happen. */
 868 }
 869
 870 XS(XS_Internals_hv_clear_placehold)
 871 {
 872     dVAR;
 873     dXSARGS;
 874     PERL_UNUSED_ARG(cv);
 875
 876     if (items != 1)
 877         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
 878     else {
 879         HV * const hv = (HV *) SvRV(ST(0));
 880         hv_clear_placeholders(hv);
 881         XSRETURN(0);
 882     }
 883 }
 884
 885 XS(XS_Regexp_DESTROY)
 886 {
 887     PERL_UNUSED_CONTEXT;
 888     PERL_UNUSED_ARG(cv);
 889 }
 890
 891 XS(XS_PerlIO_get_layers)
 892 {
 893     dVAR;
 894     dXSARGS;
 895     PERL_UNUSED_ARG(cv);
 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                                                  SVfARG(*namsvp),
 988                                                  SVfARG(*argsvp)));
 989                        else if (namok)
 990                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf,
 991                                                  SVfARG(*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     PERL_UNUSED_ARG(cv);
1043     if (SvROK(ST(0))) {
1044         const HV * const hv = (HV *) SvRV(ST(0));
1045         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1046             if (HvREHASH(hv))
1047                 XSRETURN_YES;
1048             else
1049                 XSRETURN_NO;
1050         }
1051     }
1052     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1053 }
1054
1055 XS(XS_re_is_regexp)
1056 {
1057     dVAR;
1058     dXSARGS;
1059     if (items != 1)
1060        Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
1061     PERL_UNUSED_VAR(cv); /* -W */
1062     PERL_UNUSED_VAR(ax); /* -Wall */
1063     SP -= items;
1064     {
1065         SV *    sv = ST(0);
1066         if ( Perl_get_re_arg( aTHX_ sv, 0, NULL ) )
1067         {
1068             XSRETURN_YES;
1069         } else {
1070             XSRETURN_NO;
1071         }
1072         /* NOTREACHED */
1073         PUTBACK;
1074         return;
1075     }
1076 }
1077
1078 XS(XS_re_regname)
1079 {
1080
1081     dVAR;
1082     dXSARGS;
1083     if (items < 1 || items > 2)
1084        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1085     PERL_UNUSED_VAR(cv); /* -W */
1086     PERL_UNUSED_VAR(ax); /* -Wall */
1087     SP -= items;
1088     {
1089         SV *    sv = ST(0);
1090         SV *    all;
1091         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1092         SV *bufs = NULL;
1093
1094         if (items < 2)
1095             all = NULL;
1096         else {
1097             all = ST(1);
1098         }
1099         {
1100             if (SvPOK(sv) && re && re->paren_names) {
1101                 bufs = CALLREG_NAMEDBUF_FETCH(re,sv,all && SvTRUE(all));
1102                 if (bufs) {
1103                     if (all && SvTRUE(all))
1104                         XPUSHs(newRV(bufs));
1105                     else
1106                         XPUSHs(SvREFCNT_inc(bufs));
1107                     XSRETURN(1);
1108                 }
1109             }
1110             XSRETURN_UNDEF;
1111         }
1112         PUTBACK;
1113         return;
1114     }
1115 }
1116
1117 XS(XS_re_regnames)
1118 {
1119     dVAR;
1120     dXSARGS;
1121     if (items < 0 || items > 1)
1122        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
1123     PERL_UNUSED_VAR(cv); /* -W */
1124     PERL_UNUSED_VAR(ax); /* -Wall */
1125     SP -= items;
1126     {
1127         SV *    all;
1128         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1129         IV count = 0;
1130
1131         if (items < 1)
1132             all = NULL;
1133         else {
1134             all = ST(0);
1135         }
1136         {
1137             if (re && re->paren_names) {
1138                 HV *hv= re->paren_names;
1139                 (void)hv_iterinit(hv);
1140                 while (1) {
1141                     HE *temphe = hv_iternext_flags(hv,0);
1142                     if (temphe) {
1143                         IV i;
1144                         IV parno = 0;
1145                         SV* sv_dat = HeVAL(temphe);
1146                         I32 *nums = (I32*)SvPVX(sv_dat);
1147                         for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1148                             if ((I32)(re->lastcloseparen) >= nums[i] &&
1149                                 re->offs[nums[i]].start != -1 &&
1150                                 re->offs[nums[i]].end != -1)
1151                             {
1152                                 parno = nums[i];
1153                                 break;
1154                             }
1155                         }
1156                         if (parno || (all && SvTRUE(all))) {
1157                             STRLEN len;
1158                             char *pv = HePV(temphe, len);
1159                             if ( GIMME_V == G_ARRAY )
1160                                 XPUSHs(newSVpvn(pv,len));
1161                             count++;
1162                         }
1163                     } else {
1164                         break;
1165                     }
1166                 }
1167             }
1168             if ( GIMME_V == G_ARRAY )
1169                 XSRETURN(count);
1170             else
1171                 XSRETURN_UNDEF;
1172         }
1173         PUTBACK;
1174         return;
1175     }
1176 }
1177
1178
1179 XS(XS_re_regnames_iterinit)
1180 {
1181     dVAR;
1182     dXSARGS;
1183     if (items != 0)
1184         Perl_croak(aTHX_ "Usage: re::regnames_iterinit()");
1185     PERL_UNUSED_VAR(cv); /* -W */
1186     PERL_UNUSED_VAR(ax); /* -Wall */
1187     SP -= items;
1188     {
1189         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1190         if (re && re->paren_names) {
1191             (void)hv_iterinit(re->paren_names);
1192             XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1193         } else {
1194             XSRETURN_UNDEF;
1195         }
1196         PUTBACK;
1197         return;
1198     }
1199 }
1200
1201
1202 XS(XS_re_regnames_iternext)
1203 {
1204     dVAR;
1205     dXSARGS;
1206     if (items < 0 || items > 1)
1207        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "[all]");
1208     PERL_UNUSED_VAR(cv); /* -W */
1209     PERL_UNUSED_VAR(ax); /* -Wall */
1210     SP -= items;
1211     {
1212         SV *    all;
1213         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1214
1215         if (items < 1)
1216             all = NULL;
1217         else {
1218             all = ST(0);
1219         }
1220         if (re && re->paren_names) {
1221             HV *hv= re->paren_names;
1222             while (1) {
1223                 HE *temphe = hv_iternext_flags(hv,0);
1224                 if (temphe) {
1225                     IV i;
1226                     IV parno = 0;
1227                     SV* sv_dat = HeVAL(temphe);
1228                     I32 *nums = (I32*)SvPVX(sv_dat);
1229                     for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1230                         if ((I32)(re->lastcloseparen) >= nums[i] &&
1231                             re->offs[nums[i]].start != -1 &&
1232                             re->offs[nums[i]].end != -1)
1233                         {
1234                             parno = nums[i];
1235                             break;
1236                         }
1237                     }
1238                     if (parno || (all && SvTRUE(all))) {
1239                         STRLEN len;
1240                         char *pv = HePV(temphe, len);
1241                         XPUSHs(newSVpvn(pv,len));
1242                         XSRETURN(1);
1243                     }
1244                 } else {
1245                     break;
1246                 }
1247             }
1248         }
1249         XSRETURN_UNDEF;
1250         PUTBACK;
1251         return;
1252     }
1253 }
1254
1255
1256 XS(XS_re_regnames_count)
1257 {
1258     regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1259     dVAR;
1260     dXSARGS;
1261
1262     if (items != 0)
1263        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1264     PERL_UNUSED_VAR(cv); /* -W */
1265     PERL_UNUSED_VAR(ax); /* -Wall */
1266     SP -= items;
1267
1268     if (re && re->paren_names) {
1269         XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1270     } else {
1271         XSRETURN_UNDEF;
1272     }
1273     PUTBACK;
1274     return;
1275 }
1276
1277
1278 /*
1279  * Local variables:
1280  * c-indentation-style: bsd
1281  * c-basic-offset: 4
1282  * indent-tabs-mode: t
1283  * End:
1284  *
1285  * ex: set ts=8 sts=4 sw=4 noet:
1286  */