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