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 || (HvMROMETA(basestash)->fake && !HvFILL(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("re::is_regexp", XS_re_is_regexp, file, "$");
 288     newXSproto("re::regname", XS_re_regname, file, ";$$");
 289     newXSproto("re::regnames", XS_re_regnames, file, ";$");
 290     newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, "");
 291     newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$");
 292     newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
 293 }
 294
 295
 296 XS(XS_UNIVERSAL_isa)
 297 {
 298     dVAR;
 299     dXSARGS;
 300     PERL_UNUSED_ARG(cv);
 301
 302     if (items != 2)
 303         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 304     else {
 305         SV * const sv = ST(0);
 306         const char *name;
 307
 308         SvGETMAGIC(sv);
 309
 310         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 311                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 312             XSRETURN_UNDEF;
 313
 314         name = SvPV_nolen_const(ST(1));
 315
 316         ST(0) = boolSV(sv_derived_from(sv, name));
 317         XSRETURN(1);
 318     }
 319 }
 320
 321 XS(XS_UNIVERSAL_can)
 322 {
 323     dVAR;
 324     dXSARGS;
 325     SV   *sv;
 326     const char *name;
 327     SV   *rv;
 328     HV   *pkg = NULL;
 329     PERL_UNUSED_ARG(cv);
 330
 331     if (items != 2)
 332         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 333
 334     sv = ST(0);
 335
 336     SvGETMAGIC(sv);
 337
 338     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 339                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 340         XSRETURN_UNDEF;
 341
 342     name = SvPV_nolen_const(ST(1));
 343     rv = &PL_sv_undef;
 344
 345     if (SvROK(sv)) {
 346         sv = (SV*)SvRV(sv);
 347         if (SvOBJECT(sv))
 348             pkg = SvSTASH(sv);
 349     }
 350     else {
 351         pkg = gv_stashsv(sv, 0);
 352     }
 353
 354     if (pkg) {
 355         GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 356         if (gv && isGV(gv))
 357             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 358     }
 359
 360     ST(0) = rv;
 361     XSRETURN(1);
 362 }
 363
 364 XS(XS_UNIVERSAL_DOES)
 365 {
 366     dVAR;
 367     dXSARGS;
 368     PERL_UNUSED_ARG(cv);
 369
 370     if (items != 2)
 371         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
 372     else {
 373         SV * const sv = ST(0);
 374         const char *name;
 375
 376         name = SvPV_nolen_const(ST(1));
 377         if (sv_does( sv, name ))
 378             XSRETURN_YES;
 379
 380         XSRETURN_NO;
 381     }
 382 }
 383
 384 XS(XS_UNIVERSAL_VERSION)
 385 {
 386     dVAR;
 387     dXSARGS;
 388     HV *pkg;
 389     GV **gvp;
 390     GV *gv;
 391     SV *sv;
 392     const char *undef;
 393     PERL_UNUSED_ARG(cv);
 394
 395     if (SvROK(ST(0))) {
 396         sv = (SV*)SvRV(ST(0));
 397         if (!SvOBJECT(sv))
 398             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 399         pkg = SvSTASH(sv);
 400     }
 401     else {
 402         pkg = gv_stashsv(ST(0), 0);
 403     }
 404
 405     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
 406
 407     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 408         SV * const nsv = sv_newmortal();
 409         sv_setsv(nsv, sv);
 410         sv = nsv;
 411         if ( !sv_derived_from(sv, "version"))
 412             upg_version(sv, FALSE);
 413         undef = NULL;
 414     }
 415     else {
 416         sv = (SV*)&PL_sv_undef;
 417         undef = "(undef)";
 418     }
 419
 420     if (items > 1) {
 421         SV *req = ST(1);
 422
 423         if (undef) {
 424             if (pkg) {
 425                 const char * const name = HvNAME_get(pkg);
 426                 Perl_croak(aTHX_
 427                            "%s does not define $%s::VERSION--version check failed",
 428                            name, name);
 429             } else {
 430                 Perl_croak(aTHX_
 431                              "%s defines neither package nor VERSION--version check failed",
 432                              SvPVx_nolen_const(ST(0)) );
 433              }
 434         }
 435
 436         if ( !sv_derived_from(req, "version")) {
 437             /* req may very well be R/O, so create a new object */
 438             req = sv_2mortal( new_version(req) );
 439         }
 440
 441         if ( vcmp( req, sv ) > 0 ) {
 442             if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) {
 443                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 444                        "this is only version %"SVf"", HvNAME_get(pkg),
 445                        SVfARG(vnormal(req)),
 446                        SVfARG(vnormal(sv)));
 447             } else {
 448                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 449                        "this is only version %"SVf"", HvNAME_get(pkg),
 450                        SVfARG(vstringify(req)),
 451                        SVfARG(vstringify(sv)));
 452             }
 453         }
 454
 455     }
 456
 457     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
 458         ST(0) = vstringify(sv);
 459     } else {
 460         ST(0) = sv;
 461     }
 462
 463     XSRETURN(1);
 464 }
 465
 466 XS(XS_version_new)
 467 {
 468     dVAR;
 469     dXSARGS;
 470     PERL_UNUSED_ARG(cv);
 471     if (items > 3)
 472         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 473     SP -= items;
 474     {
 475         SV *vs = ST(1);
 476         SV *rv;
 477         const char * const classname =
 478             sv_isobject(ST(0)) /* get the class if called as an object method */
 479                 ? HvNAME(SvSTASH(SvRV(ST(0))))
 480                 : (char *)SvPV_nolen(ST(0));
 481
 482         if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
 483             /* create empty object */
 484             vs = sv_newmortal();
 485             sv_setpvn(vs,"",0);
 486         }
 487         else if ( items == 3 ) {
 488             vs = sv_newmortal();
 489             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 490         }
 491
 492         rv = new_version(vs);
 493         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
 494             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 495
 496         PUSHs(sv_2mortal(rv));
 497         PUTBACK;
 498         return;
 499     }
 500 }
 501
 502 XS(XS_version_stringify)
 503 {
 504      dVAR;
 505      dXSARGS;
 506      PERL_UNUSED_ARG(cv);
 507      if (items < 1)
 508           Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
 509      SP -= items;
 510      {
 511           SV *  lobj;
 512
 513           if (sv_derived_from(ST(0), "version")) {
 514                lobj = SvRV(ST(0));
 515           }
 516           else
 517                Perl_croak(aTHX_ "lobj is not of type version");
 518
 519           PUSHs(sv_2mortal(vstringify(lobj)));
 520
 521           PUTBACK;
 522           return;
 523      }
 524 }
 525
 526 XS(XS_version_numify)
 527 {
 528      dVAR;
 529      dXSARGS;
 530      PERL_UNUSED_ARG(cv);
 531      if (items < 1)
 532           Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
 533      SP -= items;
 534      {
 535           SV *  lobj;
 536
 537           if (sv_derived_from(ST(0), "version")) {
 538                lobj = SvRV(ST(0));
 539           }
 540           else
 541                Perl_croak(aTHX_ "lobj is not of type version");
 542
 543           PUSHs(sv_2mortal(vnumify(lobj)));
 544
 545           PUTBACK;
 546           return;
 547      }
 548 }
 549
 550 XS(XS_version_normal)
 551 {
 552      dVAR;
 553      dXSARGS;
 554      PERL_UNUSED_ARG(cv);
 555      if (items < 1)
 556           Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
 557      SP -= items;
 558      {
 559           SV *  lobj;
 560
 561           if (sv_derived_from(ST(0), "version")) {
 562                lobj = SvRV(ST(0));
 563           }
 564           else
 565                Perl_croak(aTHX_ "lobj is not of type version");
 566
 567           PUSHs(sv_2mortal(vnormal(lobj)));
 568
 569           PUTBACK;
 570           return;
 571      }
 572 }
 573
 574 XS(XS_version_vcmp)
 575 {
 576      dVAR;
 577      dXSARGS;
 578      PERL_UNUSED_ARG(cv);
 579      if (items < 1)
 580           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 581      SP -= items;
 582      {
 583           SV *  lobj;
 584
 585           if (sv_derived_from(ST(0), "version")) {
 586                lobj = SvRV(ST(0));
 587           }
 588           else
 589                Perl_croak(aTHX_ "lobj is not of type version");
 590
 591           {
 592                SV       *rs;
 593                SV       *rvs;
 594                SV * robj = ST(1);
 595                const IV  swap = (IV)SvIV(ST(2));
 596
 597                if ( ! sv_derived_from(robj, "version") )
 598                {
 599                     robj = new_version(robj);
 600                }
 601                rvs = SvRV(robj);
 602
 603                if ( swap )
 604                {
 605                     rs = newSViv(vcmp(rvs,lobj));
 606                }
 607                else
 608                {
 609                     rs = newSViv(vcmp(lobj,rvs));
 610                }
 611
 612                PUSHs(sv_2mortal(rs));
 613           }
 614
 615           PUTBACK;
 616           return;
 617      }
 618 }
 619
 620 XS(XS_version_boolean)
 621 {
 622     dVAR;
 623     dXSARGS;
 624     PERL_UNUSED_ARG(cv);
 625     if (items < 1)
 626         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 627     SP -= items;
 628     if (sv_derived_from(ST(0), "version")) {
 629         SV * const lobj = SvRV(ST(0));
 630         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
 631         PUSHs(sv_2mortal(rs));
 632         PUTBACK;
 633         return;
 634     }
 635     else
 636         Perl_croak(aTHX_ "lobj is not of type version");
 637 }
 638
 639 XS(XS_version_noop)
 640 {
 641     dVAR;
 642     dXSARGS;
 643     PERL_UNUSED_ARG(cv);
 644     if (items < 1)
 645         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 646     if (sv_derived_from(ST(0), "version"))
 647         Perl_croak(aTHX_ "operation not supported with version object");
 648     else
 649         Perl_croak(aTHX_ "lobj is not of type version");
 650 #ifndef HASATTRIBUTE_NORETURN
 651     XSRETURN_EMPTY;
 652 #endif
 653 }
 654
 655 XS(XS_version_is_alpha)
 656 {
 657     dVAR;
 658     dXSARGS;
 659     PERL_UNUSED_ARG(cv);
 660     if (items != 1)
 661         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
 662     SP -= items;
 663     if (sv_derived_from(ST(0), "version")) {
 664         SV * const lobj = ST(0);
 665         if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
 666             XSRETURN_YES;
 667         else
 668             XSRETURN_NO;
 669         PUTBACK;
 670         return;
 671     }
 672     else
 673         Perl_croak(aTHX_ "lobj is not of type version");
 674 }
 675
 676 XS(XS_version_qv)
 677 {
 678     dVAR;
 679     dXSARGS;
 680     PERL_UNUSED_ARG(cv);
 681     if (items != 1)
 682         Perl_croak(aTHX_ "Usage: version::qv(ver)");
 683     SP -= items;
 684     {
 685         SV *    ver = ST(0);
 686         if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
 687             SV * const rv = sv_newmortal();
 688             sv_setsv(rv,ver); /* make a duplicate */
 689             upg_version(rv, TRUE);
 690             PUSHs(rv);
 691         }
 692         else
 693         {
 694             PUSHs(sv_2mortal(new_version(ver)));
 695         }
 696
 697         PUTBACK;
 698         return;
 699     }
 700 }
 701
 702 XS(XS_utf8_is_utf8)
 703 {
 704      dVAR;
 705      dXSARGS;
 706      PERL_UNUSED_ARG(cv);
 707      if (items != 1)
 708           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
 709      else {
 710         const SV * const sv = ST(0);
 711             if (SvUTF8(sv))
 712                 XSRETURN_YES;
 713             else
 714                 XSRETURN_NO;
 715      }
 716      XSRETURN_EMPTY;
 717 }
 718
 719 XS(XS_utf8_valid)
 720 {
 721      dVAR;
 722      dXSARGS;
 723      PERL_UNUSED_ARG(cv);
 724      if (items != 1)
 725           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 726     else {
 727         SV * const sv = ST(0);
 728         STRLEN len;
 729         const char * const s = SvPV_const(sv,len);
 730         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 731             XSRETURN_YES;
 732         else
 733             XSRETURN_NO;
 734     }
 735      XSRETURN_EMPTY;
 736 }
 737
 738 XS(XS_utf8_encode)
 739 {
 740     dVAR;
 741     dXSARGS;
 742     PERL_UNUSED_ARG(cv);
 743     if (items != 1)
 744         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 745     sv_utf8_encode(ST(0));
 746     XSRETURN_EMPTY;
 747 }
 748
 749 XS(XS_utf8_decode)
 750 {
 751     dVAR;
 752     dXSARGS;
 753     PERL_UNUSED_ARG(cv);
 754     if (items != 1)
 755         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 756     else {
 757         SV * const sv = ST(0);
 758         const bool RETVAL = sv_utf8_decode(sv);
 759         ST(0) = boolSV(RETVAL);
 760         sv_2mortal(ST(0));
 761     }
 762     XSRETURN(1);
 763 }
 764
 765 XS(XS_utf8_upgrade)
 766 {
 767     dVAR;
 768     dXSARGS;
 769     PERL_UNUSED_ARG(cv);
 770     if (items != 1)
 771         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 772     else {
 773         SV * const sv = ST(0);
 774         STRLEN  RETVAL;
 775         dXSTARG;
 776
 777         RETVAL = sv_utf8_upgrade(sv);
 778         XSprePUSH; PUSHi((IV)RETVAL);
 779     }
 780     XSRETURN(1);
 781 }
 782
 783 XS(XS_utf8_downgrade)
 784 {
 785     dVAR;
 786     dXSARGS;
 787     PERL_UNUSED_ARG(cv);
 788     if (items < 1 || items > 2)
 789         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 790     else {
 791         SV * const sv = ST(0);
 792         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 793         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 794
 795         ST(0) = boolSV(RETVAL);
 796         sv_2mortal(ST(0));
 797     }
 798     XSRETURN(1);
 799 }
 800
 801 XS(XS_utf8_native_to_unicode)
 802 {
 803  dVAR;
 804  dXSARGS;
 805  const UV uv = SvUV(ST(0));
 806  PERL_UNUSED_ARG(cv);
 807
 808  if (items > 1)
 809      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 810
 811  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 812  XSRETURN(1);
 813 }
 814
 815 XS(XS_utf8_unicode_to_native)
 816 {
 817  dVAR;
 818  dXSARGS;
 819  const UV uv = SvUV(ST(0));
 820  PERL_UNUSED_ARG(cv);
 821
 822  if (items > 1)
 823      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 824
 825  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 826  XSRETURN(1);
 827 }
 828
 829 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 830 {
 831     dVAR;
 832     dXSARGS;
 833     SV * const sv = SvRV(ST(0));
 834     PERL_UNUSED_ARG(cv);
 835
 836     if (items == 1) {
 837          if (SvREADONLY(sv))
 838              XSRETURN_YES;
 839          else
 840              XSRETURN_NO;
 841     }
 842     else if (items == 2) {
 843         if (SvTRUE(ST(1))) {
 844             SvREADONLY_on(sv);
 845             XSRETURN_YES;
 846         }
 847         else {
 848             /* I hope you really know what you are doing. */
 849             SvREADONLY_off(sv);
 850             XSRETURN_NO;
 851         }
 852     }
 853     XSRETURN_UNDEF; /* Can't happen. */
 854 }
 855
 856 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 857 {
 858     dVAR;
 859     dXSARGS;
 860     SV * const sv = SvRV(ST(0));
 861     PERL_UNUSED_ARG(cv);
 862
 863     if (items == 1)
 864          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 865     else if (items == 2) {
 866          /* I hope you really know what you are doing. */
 867          SvREFCNT(sv) = SvIV(ST(1));
 868          XSRETURN_IV(SvREFCNT(sv));
 869     }
 870     XSRETURN_UNDEF; /* Can't happen. */
 871 }
 872
 873 XS(XS_Internals_hv_clear_placehold)
 874 {
 875     dVAR;
 876     dXSARGS;
 877     PERL_UNUSED_ARG(cv);
 878
 879     if (items != 1)
 880         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
 881     else {
 882         HV * const hv = (HV *) SvRV(ST(0));
 883         hv_clear_placeholders(hv);
 884         XSRETURN(0);
 885     }
 886 }
 887
 888 XS(XS_Regexp_DESTROY)
 889 {
 890     PERL_UNUSED_CONTEXT;
 891     PERL_UNUSED_ARG(cv);
 892 }
 893
 894 XS(XS_PerlIO_get_layers)
 895 {
 896     dVAR;
 897     dXSARGS;
 898     PERL_UNUSED_ARG(cv);
 899     if (items < 1 || items % 2 == 0)
 900         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
 901 #ifdef USE_PERLIO
 902     {
 903         SV *    sv;
 904         GV *    gv;
 905         IO *    io;
 906         bool    input = TRUE;
 907         bool    details = FALSE;
 908
 909         if (items > 1) {
 910              SV * const *svp;
 911              for (svp = MARK + 2; svp <= SP; svp += 2) {
 912                   SV * const * const varp = svp;
 913                   SV * const * const valp = svp + 1;
 914                   STRLEN klen;
 915                   const char * const key = SvPV_const(*varp, klen);
 916
 917                   switch (*key) {
 918                   case 'i':
 919                        if (klen == 5 && memEQ(key, "input", 5)) {
 920                             input = SvTRUE(*valp);
 921                             break;
 922                        }
 923                        goto fail;
 924                   case 'o':
 925                        if (klen == 6 && memEQ(key, "output", 6)) {
 926                             input = !SvTRUE(*valp);
 927                             break;
 928                        }
 929                        goto fail;
 930                   case 'd':
 931                        if (klen == 7 && memEQ(key, "details", 7)) {
 932                             details = SvTRUE(*valp);
 933                             break;
 934                        }
 935                        goto fail;
 936                   default:
 937                   fail:
 938                        Perl_croak(aTHX_
 939                                   "get_layers: unknown argument '%s'",
 940                                   key);
 941                   }
 942              }
 943
 944              SP -= (items - 1);
 945         }
 946
 947         sv = POPs;
 948         gv = (GV*)sv;
 949
 950         if (!isGV(sv)) {
 951              if (SvROK(sv) && isGV(SvRV(sv)))
 952                   gv = (GV*)SvRV(sv);
 953              else if (SvPOKp(sv))
 954                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
 955         }
 956
 957         if (gv && (io = GvIO(gv))) {
 958              dTARGET;
 959              AV* const av = PerlIO_get_layers(aTHX_ input ?
 960                                         IoIFP(io) : IoOFP(io));
 961              I32 i;
 962              const I32 last = av_len(av);
 963              I32 nitem = 0;
 964
 965              for (i = last; i >= 0; i -= 3) {
 966                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 967                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 968                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 969
 970                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 971                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 972                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 973
 974                   if (details) {
 975                        XPUSHs(namok
 976                               ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
 977                               : &PL_sv_undef);
 978                        XPUSHs(argok
 979                               ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
 980                               : &PL_sv_undef);
 981                        if (flgok)
 982                             XPUSHi(SvIVX(*flgsvp));
 983                        else
 984                             XPUSHs(&PL_sv_undef);
 985                        nitem += 3;
 986                   }
 987                   else {
 988                        if (namok && argok)
 989                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 990                                                  SVfARG(*namsvp),
 991                                                  SVfARG(*argsvp)));
 992                        else if (namok)
 993                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf,
 994                                                  SVfARG(*namsvp)));
 995                        else
 996                             XPUSHs(&PL_sv_undef);
 997                        nitem++;
 998                        if (flgok) {
 999                             const IV flags = SvIVX(*flgsvp);
1000
1001                             if (flags & PERLIO_F_UTF8) {
1002                                  XPUSHs(newSVpvs("utf8"));
1003                                  nitem++;
1004                             }
1005                        }
1006                   }
1007              }
1008
1009              SvREFCNT_dec(av);
1010
1011              XSRETURN(nitem);
1012         }
1013     }
1014 #endif
1015
1016     XSRETURN(0);
1017 }
1018
1019 XS(XS_Internals_hash_seed)
1020 {
1021     dVAR;
1022     /* Using dXSARGS would also have dITEM and dSP,
1023      * which define 2 unused local variables.  */
1024     dAXMARK;
1025     PERL_UNUSED_ARG(cv);
1026     PERL_UNUSED_VAR(mark);
1027     XSRETURN_UV(PERL_HASH_SEED);
1028 }
1029
1030 XS(XS_Internals_rehash_seed)
1031 {
1032     dVAR;
1033     /* Using dXSARGS would also have dITEM and dSP,
1034      * which define 2 unused local variables.  */
1035     dAXMARK;
1036     PERL_UNUSED_ARG(cv);
1037     PERL_UNUSED_VAR(mark);
1038     XSRETURN_UV(PL_rehash_seed);
1039 }
1040
1041 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1042 {
1043     dVAR;
1044     dXSARGS;
1045     PERL_UNUSED_ARG(cv);
1046     if (SvROK(ST(0))) {
1047         const HV * const hv = (HV *) SvRV(ST(0));
1048         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1049             if (HvREHASH(hv))
1050                 XSRETURN_YES;
1051             else
1052                 XSRETURN_NO;
1053         }
1054     }
1055     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1056 }
1057
1058 XS(XS_re_is_regexp)
1059 {
1060     dVAR;
1061     dXSARGS;
1062     if (items != 1)
1063        Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
1064     PERL_UNUSED_VAR(cv); /* -W */
1065     PERL_UNUSED_VAR(ax); /* -Wall */
1066     SP -= items;
1067     {
1068         SV *    sv = ST(0);
1069         if ( Perl_get_re_arg( aTHX_ sv, 0, NULL ) )
1070         {
1071             XSRETURN_YES;
1072         } else {
1073             XSRETURN_NO;
1074         }
1075         /* NOTREACHED */
1076         PUTBACK;
1077         return;
1078     }
1079 }
1080
1081 XS(XS_re_regname)
1082 {
1083
1084     dVAR;
1085     dXSARGS;
1086     if (items < 1 || items > 2)
1087        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1088     PERL_UNUSED_VAR(cv); /* -W */
1089     PERL_UNUSED_VAR(ax); /* -Wall */
1090     SP -= items;
1091     {
1092         SV *    sv = ST(0);
1093         SV *    all;
1094         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1095         SV *bufs = NULL;
1096
1097         if (items < 2)
1098             all = NULL;
1099         else {
1100             all = ST(1);
1101         }
1102         {
1103             if (SvPOK(sv) && re && re->paren_names) {
1104                 bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all));
1105                 if (bufs) {
1106                     if (all && SvTRUE(all))
1107                         XPUSHs(newRV(bufs));
1108                     else
1109                         XPUSHs(SvREFCNT_inc(bufs));
1110                     XSRETURN(1);
1111                 }
1112             }
1113             XSRETURN_UNDEF;
1114         }
1115         PUTBACK;
1116         return;
1117     }
1118 }
1119
1120 XS(XS_re_regnames)
1121 {
1122     dVAR;
1123     dXSARGS;
1124     if (items < 0 || items > 1)
1125        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
1126     PERL_UNUSED_VAR(cv); /* -W */
1127     PERL_UNUSED_VAR(ax); /* -Wall */
1128     SP -= items;
1129     {
1130         SV *    all;
1131         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1132         IV count = 0;
1133
1134         if (items < 1)
1135             all = NULL;
1136         else {
1137             all = ST(0);
1138         }
1139         {
1140             if (re && re->paren_names) {
1141                 HV *hv= re->paren_names;
1142                 (void)hv_iterinit(hv);
1143                 while (1) {
1144                     HE *temphe = hv_iternext_flags(hv,0);
1145                     if (temphe) {
1146                         IV i;
1147                         IV parno = 0;
1148                         SV* sv_dat = HeVAL(temphe);
1149                         I32 *nums = (I32*)SvPVX(sv_dat);
1150                         for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1151                             if ((I32)(re->lastcloseparen) >= nums[i] &&
1152                                 re->offs[nums[i]].start != -1 &&
1153                                 re->offs[nums[i]].end != -1)
1154                             {
1155                                 parno = nums[i];
1156                                 break;
1157                             }
1158                         }
1159                         if (parno || (all && SvTRUE(all))) {
1160                             STRLEN len;
1161                             char *pv = HePV(temphe, len);
1162                             if ( GIMME_V == G_ARRAY )
1163                                 XPUSHs(newSVpvn(pv,len));
1164                             count++;
1165                         }
1166                     } else {
1167                         break;
1168                     }
1169                 }
1170             }
1171             if ( GIMME_V == G_ARRAY )
1172                 XSRETURN(count);
1173             else
1174                 XSRETURN_UNDEF;
1175         }
1176         PUTBACK;
1177         return;
1178     }
1179 }
1180
1181
1182 XS(XS_re_regnames_iterinit)
1183 {
1184     dVAR;
1185     dXSARGS;
1186     if (items != 0)
1187         Perl_croak(aTHX_ "Usage: re::regnames_iterinit()");
1188     PERL_UNUSED_VAR(cv); /* -W */
1189     PERL_UNUSED_VAR(ax); /* -Wall */
1190     SP -= items;
1191     {
1192         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1193         if (re && re->paren_names) {
1194             (void)hv_iterinit(re->paren_names);
1195             XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1196         } else {
1197             XSRETURN_UNDEF;
1198         }
1199         PUTBACK;
1200         return;
1201     }
1202 }
1203
1204
1205 XS(XS_re_regnames_iternext)
1206 {
1207     dVAR;
1208     dXSARGS;
1209     if (items < 0 || items > 1)
1210        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "[all]");
1211     PERL_UNUSED_VAR(cv); /* -W */
1212     PERL_UNUSED_VAR(ax); /* -Wall */
1213     SP -= items;
1214     {
1215         SV *    all;
1216         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1217
1218         if (items < 1)
1219             all = NULL;
1220         else {
1221             all = ST(0);
1222         }
1223         if (re && re->paren_names) {
1224             HV *hv= re->paren_names;
1225             while (1) {
1226                 HE *temphe = hv_iternext_flags(hv,0);
1227                 if (temphe) {
1228                     IV i;
1229                     IV parno = 0;
1230                     SV* sv_dat = HeVAL(temphe);
1231                     I32 *nums = (I32*)SvPVX(sv_dat);
1232                     for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1233                         if ((I32)(re->lastcloseparen) >= nums[i] &&
1234                             re->offs[nums[i]].start != -1 &&
1235                             re->offs[nums[i]].end != -1)
1236                         {
1237                             parno = nums[i];
1238                             break;
1239                         }
1240                     }
1241                     if (parno || (all && SvTRUE(all))) {
1242                         STRLEN len;
1243                         char *pv = HePV(temphe, len);
1244                         XPUSHs(newSVpvn(pv,len));
1245                         XSRETURN(1);
1246                     }
1247                 } else {
1248                     break;
1249                 }
1250             }
1251         }
1252         XSRETURN_UNDEF;
1253         PUTBACK;
1254         return;
1255     }
1256 }
1257
1258
1259 XS(XS_re_regnames_count)
1260 {
1261     regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1262     dVAR;
1263     dXSARGS;
1264
1265     if (items != 0)
1266        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1267     PERL_UNUSED_VAR(cv); /* -W */
1268     PERL_UNUSED_VAR(ax); /* -Wall */
1269     SP -= items;
1270
1271     if (re && re->paren_names) {
1272         XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1273     } else {
1274         XSRETURN_UNDEF;
1275     }
1276     PUTBACK;
1277     return;
1278 }
1279
1280
1281 /*
1282  * Local variables:
1283  * c-indentation-style: bsd
1284  * c-basic-offset: 4
1285  * indent-tabs-mode: t
1286  * End:
1287  *
1288  * ex: set ts=8 sts=4 sw=4 noet:
1289  */