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 *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) && isGV_with_GP(gv) && (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 #ifdef DEBUGGING
  73                 if (sv != &PL_sv_undef)
  74                     DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
  75                                     name, hvname) );
  76 #endif
  77                 return (sv == &PL_sv_yes);
  78             }
  79         }
  80         else {
  81             DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
  82                               hvname) );
  83             hv_clear(hv);
  84             sv_setiv(subgen, PL_sub_generation);
  85         }
  86     }
  87
  88     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
  89
  90     if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
  91         if (!hv || !subgen) {
  92             gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE);
  93
  94             gv = *gvp;
  95
  96             if (SvTYPE(gv) != SVt_PVGV)
  97                 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
  98
  99             if (!hv)
 100                 hv = GvHVn(gv);
 101             if (!subgen) {
 102                 subgen = newSViv(PL_sub_generation);
 103                 GvSV(gv) = subgen;
 104             }
 105         }
 106         if (hv) {
 107             SV** svp = AvARRAY(av);
 108             /* NOTE: No support for tied ISA */
 109             I32 items = AvFILLp(av) + 1;
 110             while (items--) {
 111                 SV* const sv = *svp++;
 112                 HV* const basestash = gv_stashsv(sv, 0);
 113                 if (!basestash) {
 114                     if (ckWARN(WARN_MISC))
 115                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 116                                     "Can't locate package %"SVf" for @%s::ISA",
 117                                     SVfARG(sv), hvname);
 118                     continue;
 119                 }
 120                 if (isa_lookup(basestash, name, name_stash, len, level + 1)) {
 121                     (void)hv_store(hv,name,len,&PL_sv_yes,0);
 122                     return TRUE;
 123                 }
 124             }
 125             (void)hv_store(hv,name,len,&PL_sv_no,0);
 126         }
 127     }
 128     return FALSE;
 129 }
 130
 131 /*
 132 =head1 SV Manipulation Functions
 133
 134 =for apidoc sv_derived_from
 135
 136 Returns a boolean indicating whether the SV is derived from the specified class
 137 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
 138 normal Perl method.
 139
 140 =cut
 141 */
 142
 143 bool
 144 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 145 {
 146     dVAR;
 147     HV *stash;
 148
 149     SvGETMAGIC(sv);
 150
 151     if (SvROK(sv)) {
 152         const char *type;
 153         sv = SvRV(sv);
 154         type = sv_reftype(sv,0);
 155         if (type && strEQ(type,name))
 156             return TRUE;
 157         stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
 158     }
 159     else {
 160         stash = gv_stashsv(sv, 0);
 161     }
 162
 163     if (stash) {
 164         HV * const name_stash = gv_stashpv(name, 0);
 165         return isa_lookup(stash, name, name_stash, strlen(name), 0);
 166     }
 167     else
 168         return FALSE;
 169
 170 }
 171
 172 /*
 173 =for apidoc sv_does
 174
 175 Returns a boolean indicating whether the SV performs a specific, named role.
 176 The SV can be a Perl object or the name of a Perl class.
 177
 178 =cut
 179 */
 180
 181 #include "XSUB.h"
 182
 183 bool
 184 Perl_sv_does(pTHX_ SV *sv, const char *name)
 185 {
 186     const char *classname;
 187     bool does_it;
 188
 189     dSP;
 190     ENTER;
 191     SAVETMPS;
 192
 193     SvGETMAGIC(sv);
 194
 195     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 196                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 197         return FALSE;
 198
 199     if (sv_isobject(sv)) {
 200         classname = sv_reftype(SvRV(sv),TRUE);
 201     } else {
 202         classname = SvPV(sv,PL_na);
 203     }
 204
 205     if (strEQ(name,classname))
 206         return TRUE;
 207
 208     PUSHMARK(SP);
 209     XPUSHs(sv);
 210     XPUSHs(sv_2mortal(newSVpv(name, 0)));
 211     PUTBACK;
 212
 213     call_method("isa", G_SCALAR);
 214     SPAGAIN;
 215
 216     does_it = SvTRUE( TOPs );
 217     FREETMPS;
 218     LEAVE;
 219
 220     return does_it;
 221 }
 222
 223 regexp *
 224 Perl_get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) {
 225     MAGIC *mg;
 226     if (sv) {
 227         if (SvMAGICAL(sv))
 228             mg_get(sv);
 229         if (SvROK(sv) &&
 230             (sv = (SV*)SvRV(sv)) &&     /* assign deliberate */
 231             SvTYPE(sv) == SVt_PVMG &&
 232             (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
 233         {
 234             if (mgp) *mgp = mg;
 235             return (regexp *)mg->mg_obj;
 236         }
 237     }
 238     if (mgp) *mgp = NULL;
 239     return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL);
 240 }
 241
 242
 243 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
 244 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
 245 PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
 246 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
 247 XS(XS_version_new);
 248 XS(XS_version_stringify);
 249 XS(XS_version_numify);
 250 XS(XS_version_normal);
 251 XS(XS_version_vcmp);
 252 XS(XS_version_boolean);
 253 #ifdef HASATTRIBUTE_NORETURN
 254 XS(XS_version_noop) __attribute__noreturn__;
 255 #else
 256 XS(XS_version_noop);
 257 #endif
 258 XS(XS_version_is_alpha);
 259 XS(XS_version_qv);
 260 XS(XS_utf8_is_utf8);
 261 XS(XS_utf8_valid);
 262 XS(XS_utf8_encode);
 263 XS(XS_utf8_decode);
 264 XS(XS_utf8_upgrade);
 265 XS(XS_utf8_downgrade);
 266 XS(XS_utf8_unicode_to_native);
 267 XS(XS_utf8_native_to_unicode);
 268 XS(XS_Internals_SvREADONLY);
 269 XS(XS_Internals_SvREFCNT);
 270 XS(XS_Internals_hv_clear_placehold);
 271 XS(XS_PerlIO_get_layers);
 272 XS(XS_Regexp_DESTROY);
 273 XS(XS_Internals_hash_seed);
 274 XS(XS_Internals_rehash_seed);
 275 XS(XS_Internals_HvREHASH);
 276 XS(XS_Internals_inc_sub_generation);
 277 XS(XS_re_is_regexp);
 278 XS(XS_re_regname);
 279 XS(XS_re_regnames);
 280 XS(XS_re_regnames_iterinit);
 281 XS(XS_re_regnames_iternext);
 282 XS(XS_re_regnames_count);
 283
 284 void
 285 Perl_boot_core_UNIVERSAL(pTHX)
 286 {
 287     dVAR;
 288     static const char file[] = __FILE__;
 289
 290     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
 291     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
 292     newXS("UNIVERSAL::DOES",            XS_UNIVERSAL_DOES,        file);
 293     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
 294     {
 295         /* register the overloading (type 'A') magic */
 296         PL_amagic_generation++;
 297         /* Make it findable via fetchmethod */
 298         newXS("version::()", XS_version_noop, file);
 299         newXS("version::new", XS_version_new, file);
 300         newXS("version::(\"\"", XS_version_stringify, file);
 301         newXS("version::stringify", XS_version_stringify, file);
 302         newXS("version::(0+", XS_version_numify, file);
 303         newXS("version::numify", XS_version_numify, file);
 304         newXS("version::normal", XS_version_normal, file);
 305         newXS("version::(cmp", XS_version_vcmp, file);
 306         newXS("version::(<=>", XS_version_vcmp, file);
 307         newXS("version::vcmp", XS_version_vcmp, file);
 308         newXS("version::(bool", XS_version_boolean, file);
 309         newXS("version::boolean", XS_version_boolean, file);
 310         newXS("version::(nomethod", XS_version_noop, file);
 311         newXS("version::noop", XS_version_noop, file);
 312         newXS("version::is_alpha", XS_version_is_alpha, file);
 313         newXS("version::qv", XS_version_qv, file);
 314     }
 315     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
 316     newXS("utf8::valid", XS_utf8_valid, file);
 317     newXS("utf8::encode", XS_utf8_encode, file);
 318     newXS("utf8::decode", XS_utf8_decode, file);
 319     newXS("utf8::upgrade", XS_utf8_upgrade, file);
 320     newXS("utf8::downgrade", XS_utf8_downgrade, file);
 321     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
 322     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
 323     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
 324     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 325     newXSproto("Internals::hv_clear_placeholders",
 326                XS_Internals_hv_clear_placehold, file, "\\%");
 327     newXSproto("PerlIO::get_layers",
 328                XS_PerlIO_get_layers, file, "*;@");
 329     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
 330     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
 331     newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
 332     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
 333     newXSproto("Internals::inc_sub_generation",XS_Internals_inc_sub_generation,
 334                file, "");
 335     newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
 336     newXSproto("re::regname", XS_re_regname, file, ";$$$");
 337     newXSproto("re::regnames", XS_re_regnames, file, ";$$");
 338     newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, ";$");
 339     newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$$");
 340     newXSproto("re::regnames_count", XS_re_regnames_count, file, ";$");
 341 }
 342
 343
 344 XS(XS_UNIVERSAL_isa)
 345 {
 346     dVAR;
 347     dXSARGS;
 348     PERL_UNUSED_ARG(cv);
 349
 350     if (items != 2)
 351         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 352     else {
 353         SV * const sv = ST(0);
 354         const char *name;
 355
 356         SvGETMAGIC(sv);
 357
 358         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 359                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 360             XSRETURN_UNDEF;
 361
 362         name = SvPV_nolen_const(ST(1));
 363
 364         ST(0) = boolSV(sv_derived_from(sv, name));
 365         XSRETURN(1);
 366     }
 367 }
 368
 369 XS(XS_UNIVERSAL_can)
 370 {
 371     dVAR;
 372     dXSARGS;
 373     SV   *sv;
 374     const char *name;
 375     SV   *rv;
 376     HV   *pkg = NULL;
 377     PERL_UNUSED_ARG(cv);
 378
 379     if (items != 2)
 380         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 381
 382     sv = ST(0);
 383
 384     SvGETMAGIC(sv);
 385
 386     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 387                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 388         XSRETURN_UNDEF;
 389
 390     name = SvPV_nolen_const(ST(1));
 391     rv = &PL_sv_undef;
 392
 393     if (SvROK(sv)) {
 394         sv = (SV*)SvRV(sv);
 395         if (SvOBJECT(sv))
 396             pkg = SvSTASH(sv);
 397     }
 398     else {
 399         pkg = gv_stashsv(sv, 0);
 400     }
 401
 402     if (pkg) {
 403         GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 404         if (gv && isGV(gv))
 405             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 406     }
 407
 408     ST(0) = rv;
 409     XSRETURN(1);
 410 }
 411
 412 XS(XS_UNIVERSAL_DOES)
 413 {
 414     dVAR;
 415     dXSARGS;
 416     PERL_UNUSED_ARG(cv);
 417
 418     if (items != 2)
 419         Perl_croak(aTHX_ "Usage: invocant->does(kind)");
 420     else {
 421         SV * const sv = ST(0);
 422         const char *name;
 423
 424         name = SvPV_nolen_const(ST(1));
 425         if (sv_does( sv, name ))
 426             XSRETURN_YES;
 427
 428         XSRETURN_NO;
 429     }
 430 }
 431
 432 XS(XS_UNIVERSAL_VERSION)
 433 {
 434     dVAR;
 435     dXSARGS;
 436     HV *pkg;
 437     GV **gvp;
 438     GV *gv;
 439     SV *sv;
 440     const char *undef;
 441     PERL_UNUSED_ARG(cv);
 442
 443     if (SvROK(ST(0))) {
 444         sv = (SV*)SvRV(ST(0));
 445         if (!SvOBJECT(sv))
 446             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 447         pkg = SvSTASH(sv);
 448     }
 449     else {
 450         pkg = gv_stashsv(ST(0), 0);
 451     }
 452
 453     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
 454
 455     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 456         SV * const nsv = sv_newmortal();
 457         sv_setsv(nsv, sv);
 458         sv = nsv;
 459         if ( !sv_derived_from(sv, "version"))
 460             upg_version(sv);
 461         undef = NULL;
 462     }
 463     else {
 464         sv = (SV*)&PL_sv_undef;
 465         undef = "(undef)";
 466     }
 467
 468     if (items > 1) {
 469         SV *req = ST(1);
 470
 471         if (undef) {
 472             if (pkg) {
 473                 const char * const name = HvNAME_get(pkg);
 474                 Perl_croak(aTHX_
 475                            "%s does not define $%s::VERSION--version check failed",
 476                            name, name);
 477             } else {
 478                 Perl_croak(aTHX_
 479                              "%s defines neither package nor VERSION--version check failed",
 480                              SvPVx_nolen_const(ST(0)) );
 481              }
 482         }
 483
 484         if ( !sv_derived_from(req, "version")) {
 485             /* req may very well be R/O, so create a new object */
 486             SV * const nsv = sv_newmortal();
 487             sv_setsv(nsv, req);
 488             req = nsv;
 489             upg_version(req);
 490         }
 491
 492         if ( vcmp( req, sv ) > 0 )
 493             Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
 494                        "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg),
 495                        SVfARG(vnumify(req)),
 496                        SVfARG(vnormal(req)),
 497                        SVfARG(vnumify(sv)),
 498                        SVfARG(vnormal(sv)));
 499     }
 500
 501     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
 502         ST(0) = vnumify(sv);
 503     } else {
 504         ST(0) = sv;
 505     }
 506
 507     XSRETURN(1);
 508 }
 509
 510 XS(XS_version_new)
 511 {
 512     dVAR;
 513     dXSARGS;
 514     PERL_UNUSED_ARG(cv);
 515     if (items > 3)
 516         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 517     SP -= items;
 518     {
 519         SV *vs = ST(1);
 520         SV *rv;
 521         const char * const classname =
 522             sv_isobject(ST(0)) /* get the class if called as an object method */
 523                 ? HvNAME(SvSTASH(SvRV(ST(0))))
 524                 : (char *)SvPV_nolen(ST(0));
 525
 526         if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
 527             /* create empty object */
 528             vs = sv_newmortal();
 529             sv_setpvn(vs,"",0);
 530         }
 531         else if ( items == 3 ) {
 532             vs = sv_newmortal();
 533             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 534         }
 535
 536         rv = new_version(vs);
 537         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
 538             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 539
 540         PUSHs(sv_2mortal(rv));
 541         PUTBACK;
 542         return;
 543     }
 544 }
 545
 546 XS(XS_version_stringify)
 547 {
 548      dVAR;
 549      dXSARGS;
 550      PERL_UNUSED_ARG(cv);
 551      if (items < 1)
 552           Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
 553      SP -= items;
 554      {
 555           SV *  lobj;
 556
 557           if (sv_derived_from(ST(0), "version")) {
 558                lobj = SvRV(ST(0));
 559           }
 560           else
 561                Perl_croak(aTHX_ "lobj is not of type version");
 562
 563           PUSHs(sv_2mortal(vstringify(lobj)));
 564
 565           PUTBACK;
 566           return;
 567      }
 568 }
 569
 570 XS(XS_version_numify)
 571 {
 572      dVAR;
 573      dXSARGS;
 574      PERL_UNUSED_ARG(cv);
 575      if (items < 1)
 576           Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
 577      SP -= items;
 578      {
 579           SV *  lobj;
 580
 581           if (sv_derived_from(ST(0), "version")) {
 582                lobj = SvRV(ST(0));
 583           }
 584           else
 585                Perl_croak(aTHX_ "lobj is not of type version");
 586
 587           PUSHs(sv_2mortal(vnumify(lobj)));
 588
 589           PUTBACK;
 590           return;
 591      }
 592 }
 593
 594 XS(XS_version_normal)
 595 {
 596      dVAR;
 597      dXSARGS;
 598      PERL_UNUSED_ARG(cv);
 599      if (items < 1)
 600           Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
 601      SP -= items;
 602      {
 603           SV *  lobj;
 604
 605           if (sv_derived_from(ST(0), "version")) {
 606                lobj = SvRV(ST(0));
 607           }
 608           else
 609                Perl_croak(aTHX_ "lobj is not of type version");
 610
 611           PUSHs(sv_2mortal(vnormal(lobj)));
 612
 613           PUTBACK;
 614           return;
 615      }
 616 }
 617
 618 XS(XS_version_vcmp)
 619 {
 620      dVAR;
 621      dXSARGS;
 622      PERL_UNUSED_ARG(cv);
 623      if (items < 1)
 624           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 625      SP -= items;
 626      {
 627           SV *  lobj;
 628
 629           if (sv_derived_from(ST(0), "version")) {
 630                lobj = SvRV(ST(0));
 631           }
 632           else
 633                Perl_croak(aTHX_ "lobj is not of type version");
 634
 635           {
 636                SV       *rs;
 637                SV       *rvs;
 638                SV * robj = ST(1);
 639                const IV  swap = (IV)SvIV(ST(2));
 640
 641                if ( ! sv_derived_from(robj, "version") )
 642                {
 643                     robj = new_version(robj);
 644                }
 645                rvs = SvRV(robj);
 646
 647                if ( swap )
 648                {
 649                     rs = newSViv(vcmp(rvs,lobj));
 650                }
 651                else
 652                {
 653                     rs = newSViv(vcmp(lobj,rvs));
 654                }
 655
 656                PUSHs(sv_2mortal(rs));
 657           }
 658
 659           PUTBACK;
 660           return;
 661      }
 662 }
 663
 664 XS(XS_version_boolean)
 665 {
 666     dVAR;
 667     dXSARGS;
 668     PERL_UNUSED_ARG(cv);
 669     if (items < 1)
 670         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 671     SP -= items;
 672     if (sv_derived_from(ST(0), "version")) {
 673         SV * const lobj = SvRV(ST(0));
 674         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
 675         PUSHs(sv_2mortal(rs));
 676         PUTBACK;
 677         return;
 678     }
 679     else
 680         Perl_croak(aTHX_ "lobj is not of type version");
 681 }
 682
 683 XS(XS_version_noop)
 684 {
 685     dVAR;
 686     dXSARGS;
 687     PERL_UNUSED_ARG(cv);
 688     if (items < 1)
 689         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 690     if (sv_derived_from(ST(0), "version"))
 691         Perl_croak(aTHX_ "operation not supported with version object");
 692     else
 693         Perl_croak(aTHX_ "lobj is not of type version");
 694 #ifndef HASATTRIBUTE_NORETURN
 695     XSRETURN_EMPTY;
 696 #endif
 697 }
 698
 699 XS(XS_version_is_alpha)
 700 {
 701     dVAR;
 702     dXSARGS;
 703     PERL_UNUSED_ARG(cv);
 704     if (items != 1)
 705         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
 706     SP -= items;
 707     if (sv_derived_from(ST(0), "version")) {
 708         SV * const lobj = ST(0);
 709         if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
 710             XSRETURN_YES;
 711         else
 712             XSRETURN_NO;
 713         PUTBACK;
 714         return;
 715     }
 716     else
 717         Perl_croak(aTHX_ "lobj is not of type version");
 718 }
 719
 720 XS(XS_version_qv)
 721 {
 722     dVAR;
 723     dXSARGS;
 724     PERL_UNUSED_ARG(cv);
 725     if (items != 1)
 726         Perl_croak(aTHX_ "Usage: version::qv(ver)");
 727     SP -= items;
 728     {
 729         SV *    ver = ST(0);
 730         if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
 731             SV * const vs = sv_newmortal();
 732             char *version;
 733             if ( SvNOK(ver) ) /* may get too much accuracy */
 734             {
 735                 char tbuf[64];
 736 #ifdef USE_LOCALE_NUMERIC
 737                 char *loc = setlocale(LC_NUMERIC, "C");
 738 #endif
 739                 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver));
 740 #ifdef USE_LOCALE_NUMERIC
 741                 setlocale(LC_NUMERIC, loc);
 742 #endif
 743                 while (tbuf[len-1] == '0' && len > 0) len--;
 744                 version = savepvn(tbuf, len);
 745             }
 746             else
 747             {
 748                 version = savesvpv(ver);
 749             }
 750             (void)scan_version(version,vs,TRUE);
 751             Safefree(version);
 752
 753             PUSHs(vs);
 754         }
 755         else
 756         {
 757             PUSHs(sv_2mortal(new_version(ver)));
 758         }
 759
 760         PUTBACK;
 761         return;
 762     }
 763 }
 764
 765 XS(XS_utf8_is_utf8)
 766 {
 767      dVAR;
 768      dXSARGS;
 769      PERL_UNUSED_ARG(cv);
 770      if (items != 1)
 771           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
 772      else {
 773         const SV * const sv = ST(0);
 774             if (SvUTF8(sv))
 775                 XSRETURN_YES;
 776             else
 777                 XSRETURN_NO;
 778      }
 779      XSRETURN_EMPTY;
 780 }
 781
 782 XS(XS_utf8_valid)
 783 {
 784      dVAR;
 785      dXSARGS;
 786      PERL_UNUSED_ARG(cv);
 787      if (items != 1)
 788           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 789     else {
 790         SV * const sv = ST(0);
 791         STRLEN len;
 792         const char * const s = SvPV_const(sv,len);
 793         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 794             XSRETURN_YES;
 795         else
 796             XSRETURN_NO;
 797     }
 798      XSRETURN_EMPTY;
 799 }
 800
 801 XS(XS_utf8_encode)
 802 {
 803     dVAR;
 804     dXSARGS;
 805     PERL_UNUSED_ARG(cv);
 806     if (items != 1)
 807         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 808     sv_utf8_encode(ST(0));
 809     XSRETURN_EMPTY;
 810 }
 811
 812 XS(XS_utf8_decode)
 813 {
 814     dVAR;
 815     dXSARGS;
 816     PERL_UNUSED_ARG(cv);
 817     if (items != 1)
 818         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 819     else {
 820         SV * const sv = ST(0);
 821         const bool RETVAL = sv_utf8_decode(sv);
 822         ST(0) = boolSV(RETVAL);
 823         sv_2mortal(ST(0));
 824     }
 825     XSRETURN(1);
 826 }
 827
 828 XS(XS_utf8_upgrade)
 829 {
 830     dVAR;
 831     dXSARGS;
 832     PERL_UNUSED_ARG(cv);
 833     if (items != 1)
 834         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 835     else {
 836         SV * const sv = ST(0);
 837         STRLEN  RETVAL;
 838         dXSTARG;
 839
 840         RETVAL = sv_utf8_upgrade(sv);
 841         XSprePUSH; PUSHi((IV)RETVAL);
 842     }
 843     XSRETURN(1);
 844 }
 845
 846 XS(XS_utf8_downgrade)
 847 {
 848     dVAR;
 849     dXSARGS;
 850     PERL_UNUSED_ARG(cv);
 851     if (items < 1 || items > 2)
 852         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 853     else {
 854         SV * const sv = ST(0);
 855         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 856         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 857
 858         ST(0) = boolSV(RETVAL);
 859         sv_2mortal(ST(0));
 860     }
 861     XSRETURN(1);
 862 }
 863
 864 XS(XS_utf8_native_to_unicode)
 865 {
 866  dVAR;
 867  dXSARGS;
 868  const UV uv = SvUV(ST(0));
 869  PERL_UNUSED_ARG(cv);
 870
 871  if (items > 1)
 872      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 873
 874  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 875  XSRETURN(1);
 876 }
 877
 878 XS(XS_utf8_unicode_to_native)
 879 {
 880  dVAR;
 881  dXSARGS;
 882  const UV uv = SvUV(ST(0));
 883  PERL_UNUSED_ARG(cv);
 884
 885  if (items > 1)
 886      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 887
 888  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 889  XSRETURN(1);
 890 }
 891
 892 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 893 {
 894     dVAR;
 895     dXSARGS;
 896     SV * const sv = SvRV(ST(0));
 897     PERL_UNUSED_ARG(cv);
 898
 899     if (items == 1) {
 900          if (SvREADONLY(sv))
 901              XSRETURN_YES;
 902          else
 903              XSRETURN_NO;
 904     }
 905     else if (items == 2) {
 906         if (SvTRUE(ST(1))) {
 907             SvREADONLY_on(sv);
 908             XSRETURN_YES;
 909         }
 910         else {
 911             /* I hope you really know what you are doing. */
 912             SvREADONLY_off(sv);
 913             XSRETURN_NO;
 914         }
 915     }
 916     XSRETURN_UNDEF; /* Can't happen. */
 917 }
 918
 919 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 920 {
 921     dVAR;
 922     dXSARGS;
 923     SV * const sv = SvRV(ST(0));
 924     PERL_UNUSED_ARG(cv);
 925
 926     if (items == 1)
 927          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 928     else if (items == 2) {
 929          /* I hope you really know what you are doing. */
 930          SvREFCNT(sv) = SvIV(ST(1));
 931          XSRETURN_IV(SvREFCNT(sv));
 932     }
 933     XSRETURN_UNDEF; /* Can't happen. */
 934 }
 935
 936 XS(XS_Internals_hv_clear_placehold)
 937 {
 938     dVAR;
 939     dXSARGS;
 940     PERL_UNUSED_ARG(cv);
 941
 942     if (items != 1)
 943         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
 944     else {
 945         HV * const hv = (HV *) SvRV(ST(0));
 946         hv_clear_placeholders(hv);
 947         XSRETURN(0);
 948     }
 949 }
 950
 951 XS(XS_Regexp_DESTROY)
 952 {
 953     PERL_UNUSED_CONTEXT;
 954     PERL_UNUSED_ARG(cv);
 955 }
 956
 957 XS(XS_PerlIO_get_layers)
 958 {
 959     dVAR;
 960     dXSARGS;
 961     PERL_UNUSED_ARG(cv);
 962     if (items < 1 || items % 2 == 0)
 963         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
 964 #ifdef USE_PERLIO
 965     {
 966         SV *    sv;
 967         GV *    gv;
 968         IO *    io;
 969         bool    input = TRUE;
 970         bool    details = FALSE;
 971
 972         if (items > 1) {
 973              SV * const *svp;
 974              for (svp = MARK + 2; svp <= SP; svp += 2) {
 975                   SV * const * const varp = svp;
 976                   SV * const * const valp = svp + 1;
 977                   STRLEN klen;
 978                   const char * const key = SvPV_const(*varp, klen);
 979
 980                   switch (*key) {
 981                   case 'i':
 982                        if (klen == 5 && memEQ(key, "input", 5)) {
 983                             input = SvTRUE(*valp);
 984                             break;
 985                        }
 986                        goto fail;
 987                   case 'o':
 988                        if (klen == 6 && memEQ(key, "output", 6)) {
 989                             input = !SvTRUE(*valp);
 990                             break;
 991                        }
 992                        goto fail;
 993                   case 'd':
 994                        if (klen == 7 && memEQ(key, "details", 7)) {
 995                             details = SvTRUE(*valp);
 996                             break;
 997                        }
 998                        goto fail;
 999                   default:
1000                   fail:
1001                        Perl_croak(aTHX_
1002                                   "get_layers: unknown argument '%s'",
1003                                   key);
1004                   }
1005              }
1006
1007              SP -= (items - 1);
1008         }
1009
1010         sv = POPs;
1011         gv = (GV*)sv;
1012
1013         if (!isGV(sv)) {
1014              if (SvROK(sv) && isGV(SvRV(sv)))
1015                   gv = (GV*)SvRV(sv);
1016              else if (SvPOKp(sv))
1017                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
1018         }
1019
1020         if (gv && (io = GvIO(gv))) {
1021              dTARGET;
1022              AV* const av = PerlIO_get_layers(aTHX_ input ?
1023                                         IoIFP(io) : IoOFP(io));
1024              I32 i;
1025              const I32 last = av_len(av);
1026              I32 nitem = 0;
1027
1028              for (i = last; i >= 0; i -= 3) {
1029                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1030                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1031                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
1032
1033                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1034                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1035                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1036
1037                   if (details) {
1038                        XPUSHs(namok
1039                               ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
1040                               : &PL_sv_undef);
1041                        XPUSHs(argok
1042                               ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
1043                               : &PL_sv_undef);
1044                        if (flgok)
1045                             XPUSHi(SvIVX(*flgsvp));
1046                        else
1047                             XPUSHs(&PL_sv_undef);
1048                        nitem += 3;
1049                   }
1050                   else {
1051                        if (namok && argok)
1052                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1053                                                  SVfARG(*namsvp),
1054                                                  SVfARG(*argsvp)));
1055                        else if (namok)
1056                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf,
1057                                                  SVfARG(*namsvp)));
1058                        else
1059                             XPUSHs(&PL_sv_undef);
1060                        nitem++;
1061                        if (flgok) {
1062                             const IV flags = SvIVX(*flgsvp);
1063
1064                             if (flags & PERLIO_F_UTF8) {
1065                                  XPUSHs(newSVpvs("utf8"));
1066                                  nitem++;
1067                             }
1068                        }
1069                   }
1070              }
1071
1072              SvREFCNT_dec(av);
1073
1074              XSRETURN(nitem);
1075         }
1076     }
1077 #endif
1078
1079     XSRETURN(0);
1080 }
1081
1082 XS(XS_Internals_hash_seed)
1083 {
1084     dVAR;
1085     /* Using dXSARGS would also have dITEM and dSP,
1086      * which define 2 unused local variables.  */
1087     dAXMARK;
1088     PERL_UNUSED_ARG(cv);
1089     PERL_UNUSED_VAR(mark);
1090     XSRETURN_UV(PERL_HASH_SEED);
1091 }
1092
1093 XS(XS_Internals_rehash_seed)
1094 {
1095     dVAR;
1096     /* Using dXSARGS would also have dITEM and dSP,
1097      * which define 2 unused local variables.  */
1098     dAXMARK;
1099     PERL_UNUSED_ARG(cv);
1100     PERL_UNUSED_VAR(mark);
1101     XSRETURN_UV(PL_rehash_seed);
1102 }
1103
1104 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1105 {
1106     dVAR;
1107     dXSARGS;
1108     PERL_UNUSED_ARG(cv);
1109     if (SvROK(ST(0))) {
1110         const HV * const hv = (HV *) SvRV(ST(0));
1111         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1112             if (HvREHASH(hv))
1113                 XSRETURN_YES;
1114             else
1115                 XSRETURN_NO;
1116         }
1117     }
1118     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1119 }
1120
1121 XS(XS_Internals_inc_sub_generation)
1122 {
1123     dVAR;
1124     /* Using dXSARGS would also have dITEM and dSP,
1125      * which define 2 unused local variables.  */
1126     dAXMARK;
1127     PERL_UNUSED_ARG(cv);
1128     PERL_UNUSED_VAR(mark);
1129     ++PL_sub_generation;
1130     XSRETURN_EMPTY;
1131 }
1132
1133 XS(XS_re_is_regexp)
1134 {
1135     dVAR;
1136     dXSARGS;
1137     if (items != 1)
1138        Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
1139     PERL_UNUSED_VAR(cv); /* -W */
1140     PERL_UNUSED_VAR(ax); /* -Wall */
1141     SP -= items;
1142     {
1143         SV *    sv = ST(0);
1144         if ( Perl_get_re_arg( aTHX_ sv, 0, NULL ) )
1145         {
1146             XSRETURN_YES;
1147         } else {
1148             XSRETURN_NO;
1149         }
1150         /* NOTREACHED */
1151         PUTBACK;
1152         return;
1153     }
1154 }
1155
1156 XS(XS_re_regname)
1157 {
1158
1159     dVAR;
1160     dXSARGS;
1161     if (items < 1 || items > 3)
1162        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "sv, qr = NULL, all = NULL");
1163     PERL_UNUSED_VAR(cv); /* -W */
1164     PERL_UNUSED_VAR(ax); /* -Wall */
1165     SP -= items;
1166     {
1167         SV *    sv = ST(0);
1168         SV *    qr;
1169         SV *    all;
1170         regexp *re = NULL;
1171         SV *bufs = NULL;
1172
1173         if (items < 2)
1174             qr = NULL;
1175         else {
1176             qr = ST(1);
1177         }
1178
1179         if (items < 3)
1180             all = NULL;
1181         else {
1182             all = ST(2);
1183         }
1184         {
1185             re = Perl_get_re_arg( aTHX_ qr, 1, NULL);
1186             if (SvPOK(sv) && re && re->paren_names) {
1187                 bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all));
1188                 if (bufs) {
1189                     if (all && SvTRUE(all))
1190                         XPUSHs(newRV(bufs));
1191                     else
1192                         XPUSHs(SvREFCNT_inc(bufs));
1193                     XSRETURN(1);
1194                 }
1195             }
1196             XSRETURN_UNDEF;
1197         }
1198         PUTBACK;
1199         return;
1200     }
1201 }
1202
1203 XS(XS_re_regnames)
1204 {
1205     dVAR;
1206     dXSARGS;
1207     if (items < 0 || items > 2)
1208        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "sv = NULL, all = NULL");
1209     PERL_UNUSED_VAR(cv); /* -W */
1210     PERL_UNUSED_VAR(ax); /* -Wall */
1211     SP -= items;
1212     {
1213         SV *    sv;
1214         SV *    all;
1215         regexp *re = NULL;
1216         IV count = 0;
1217
1218         if (items < 1)
1219             sv = NULL;
1220         else {
1221             sv = ST(0);
1222         }
1223
1224         if (items < 2)
1225             all = NULL;
1226         else {
1227             all = ST(1);
1228         }
1229         {
1230             re = Perl_get_re_arg( aTHX_  sv, 1, NULL );
1231             if (re && re->paren_names) {
1232                 HV *hv= re->paren_names;
1233                 (void)hv_iterinit(hv);
1234                 while (1) {
1235                     HE *temphe = hv_iternext_flags(hv,0);
1236                     if (temphe) {
1237                         IV i;
1238                         IV parno = 0;
1239                         SV* sv_dat = HeVAL(temphe);
1240                         I32 *nums = (I32*)SvPVX(sv_dat);
1241                         for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1242                             if ((I32)(re->lastcloseparen) >= nums[i] &&
1243                                 re->startp[nums[i]] != -1 &&
1244                                 re->endp[nums[i]] != -1)
1245                             {
1246                                 parno = nums[i];
1247                                 break;
1248                             }
1249                         }
1250                         if (parno || (all && SvTRUE(all))) {
1251                             STRLEN len;
1252                             char *pv = HePV(temphe, len);
1253                             if ( GIMME_V == G_ARRAY )
1254                                 XPUSHs(newSVpvn(pv,len));
1255                             count++;
1256                         }
1257                     } else {
1258                         break;
1259                     }
1260                 }
1261             }
1262             if ( GIMME_V == G_ARRAY )
1263                 XSRETURN(count);
1264             else
1265                 XSRETURN_UNDEF;
1266         }
1267         PUTBACK;
1268         return;
1269     }
1270 }
1271
1272
1273 XS(XS_re_regnames_iterinit)
1274 {
1275     dVAR;
1276     dXSARGS;
1277     if (items < 0 || items > 1)
1278        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iterinit", "sv = NULL");
1279     PERL_UNUSED_VAR(cv); /* -W */
1280     PERL_UNUSED_VAR(ax); /* -Wall */
1281     SP -= items;
1282     {
1283         SV *    sv;
1284         regexp *re = NULL;
1285
1286         if (items < 1)
1287             sv = NULL;
1288         else {
1289             sv = ST(0);
1290         }
1291         {
1292             re = Perl_get_re_arg( aTHX_  sv, 1, NULL );
1293             if (re && re->paren_names) {
1294                 (void)hv_iterinit(re->paren_names);
1295                 XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1296             } else {
1297                 XSRETURN_UNDEF;
1298             }
1299         }
1300         PUTBACK;
1301         return;
1302     }
1303 }
1304
1305
1306 XS(XS_re_regnames_iternext)
1307 {
1308     dVAR;
1309     dXSARGS;
1310     if (items < 0 || items > 2)
1311        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "sv = NULL, all = NULL");
1312     PERL_UNUSED_VAR(cv); /* -W */
1313     PERL_UNUSED_VAR(ax); /* -Wall */
1314     SP -= items;
1315     {
1316         SV *    sv;
1317         SV *    all;
1318         regexp *re;
1319
1320         if (items < 1)
1321             sv = NULL;
1322         else {
1323             sv = ST(0);
1324         }
1325
1326         if (items < 2)
1327             all = NULL;
1328         else {
1329             all = ST(1);
1330         }
1331         {
1332             re = Perl_get_re_arg( aTHX_  sv, 1, NULL );
1333             if (re && re->paren_names) {
1334                 HV *hv= re->paren_names;
1335                 while (1) {
1336                     HE *temphe = hv_iternext_flags(hv,0);
1337                     if (temphe) {
1338                         IV i;
1339                         IV parno = 0;
1340                         SV* sv_dat = HeVAL(temphe);
1341                         I32 *nums = (I32*)SvPVX(sv_dat);
1342                         for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1343                             if ((I32)(re->lastcloseparen) >= nums[i] &&
1344                                 re->startp[nums[i]] != -1 &&
1345                                 re->endp[nums[i]] != -1)
1346                             {
1347                                 parno = nums[i];
1348                                 break;
1349                             }
1350                         }
1351                         if (parno || (all && SvTRUE(all))) {
1352                             STRLEN len;
1353                             char *pv = HePV(temphe, len);
1354                             XPUSHs(newSVpvn(pv,len));
1355                             XSRETURN(1);
1356                         }
1357                     } else {
1358                         break;
1359                     }
1360                 }
1361             }
1362             XSRETURN_UNDEF;
1363         }
1364         PUTBACK;
1365         return;
1366     }
1367 }
1368
1369
1370 XS(XS_re_regnames_count)
1371 {
1372     SV *        sv;
1373     regexp *re = NULL;
1374     dVAR;
1375     dXSARGS;
1376
1377     if (items < 0 || items > 1)
1378        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "sv = NULL");
1379     PERL_UNUSED_VAR(cv); /* -W */
1380     PERL_UNUSED_VAR(ax); /* -Wall */
1381     SP -= items;
1382     if (items < 1)
1383         sv = NULL;
1384     else {
1385         sv = ST(0);
1386     }
1387     re = Perl_get_re_arg( aTHX_  sv, 1, NULL );
1388     if (re && re->paren_names) {
1389         XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1390     } else {
1391         XSRETURN_UNDEF;
1392     }
1393     PUTBACK;
1394     return;
1395 }
1396
1397
1398 /*
1399  * Local variables:
1400  * c-indentation-style: bsd
1401  * c-basic-offset: 4
1402  * indent-tabs-mode: t
1403  * End:
1404  *
1405  * ex: set ts=8 sts=4 sw=4 noet:
1406  */