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, FALSE);
 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             req = sv_2mortal( new_version(req) );
 487         }
 488
 489         if ( vcmp( req, sv ) > 0 ) {
 490             if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) {
 491                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 492                        "this is only version %"SVf"", HvNAME_get(pkg),
 493                        SVfARG(vnormal(req)),
 494                        SVfARG(vnormal(sv)));
 495             } else {
 496                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 497                        "this is only version %"SVf"", HvNAME_get(pkg),
 498                        SVfARG(vnumify(req)),
 499                        SVfARG(vnumify(sv)));
 500             }
 501         }
 502
 503     }
 504
 505     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
 506         ST(0) = vnumify(sv);
 507     } else {
 508         ST(0) = sv;
 509     }
 510
 511     XSRETURN(1);
 512 }
 513
 514 XS(XS_version_new)
 515 {
 516     dVAR;
 517     dXSARGS;
 518     PERL_UNUSED_ARG(cv);
 519     if (items > 3)
 520         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 521     SP -= items;
 522     {
 523         SV *vs = ST(1);
 524         SV *rv;
 525         const char * const classname =
 526             sv_isobject(ST(0)) /* get the class if called as an object method */
 527                 ? HvNAME(SvSTASH(SvRV(ST(0))))
 528                 : (char *)SvPV_nolen(ST(0));
 529
 530         if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
 531             /* create empty object */
 532             vs = sv_newmortal();
 533             sv_setpvn(vs,"",0);
 534         }
 535         else if ( items == 3 ) {
 536             vs = sv_newmortal();
 537             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 538         }
 539
 540         rv = new_version(vs);
 541         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
 542             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 543
 544         PUSHs(sv_2mortal(rv));
 545         PUTBACK;
 546         return;
 547     }
 548 }
 549
 550 XS(XS_version_stringify)
 551 {
 552      dVAR;
 553      dXSARGS;
 554      PERL_UNUSED_ARG(cv);
 555      if (items < 1)
 556           Perl_croak(aTHX_ "Usage: version::stringify(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(vstringify(lobj)));
 568
 569           PUTBACK;
 570           return;
 571      }
 572 }
 573
 574 XS(XS_version_numify)
 575 {
 576      dVAR;
 577      dXSARGS;
 578      PERL_UNUSED_ARG(cv);
 579      if (items < 1)
 580           Perl_croak(aTHX_ "Usage: version::numify(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           PUSHs(sv_2mortal(vnumify(lobj)));
 592
 593           PUTBACK;
 594           return;
 595      }
 596 }
 597
 598 XS(XS_version_normal)
 599 {
 600      dVAR;
 601      dXSARGS;
 602      PERL_UNUSED_ARG(cv);
 603      if (items < 1)
 604           Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
 605      SP -= items;
 606      {
 607           SV *  lobj;
 608
 609           if (sv_derived_from(ST(0), "version")) {
 610                lobj = SvRV(ST(0));
 611           }
 612           else
 613                Perl_croak(aTHX_ "lobj is not of type version");
 614
 615           PUSHs(sv_2mortal(vnormal(lobj)));
 616
 617           PUTBACK;
 618           return;
 619      }
 620 }
 621
 622 XS(XS_version_vcmp)
 623 {
 624      dVAR;
 625      dXSARGS;
 626      PERL_UNUSED_ARG(cv);
 627      if (items < 1)
 628           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 629      SP -= items;
 630      {
 631           SV *  lobj;
 632
 633           if (sv_derived_from(ST(0), "version")) {
 634                lobj = SvRV(ST(0));
 635           }
 636           else
 637                Perl_croak(aTHX_ "lobj is not of type version");
 638
 639           {
 640                SV       *rs;
 641                SV       *rvs;
 642                SV * robj = ST(1);
 643                const IV  swap = (IV)SvIV(ST(2));
 644
 645                if ( ! sv_derived_from(robj, "version") )
 646                {
 647                     robj = new_version(robj);
 648                }
 649                rvs = SvRV(robj);
 650
 651                if ( swap )
 652                {
 653                     rs = newSViv(vcmp(rvs,lobj));
 654                }
 655                else
 656                {
 657                     rs = newSViv(vcmp(lobj,rvs));
 658                }
 659
 660                PUSHs(sv_2mortal(rs));
 661           }
 662
 663           PUTBACK;
 664           return;
 665      }
 666 }
 667
 668 XS(XS_version_boolean)
 669 {
 670     dVAR;
 671     dXSARGS;
 672     PERL_UNUSED_ARG(cv);
 673     if (items < 1)
 674         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 675     SP -= items;
 676     if (sv_derived_from(ST(0), "version")) {
 677         SV * const lobj = SvRV(ST(0));
 678         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
 679         PUSHs(sv_2mortal(rs));
 680         PUTBACK;
 681         return;
 682     }
 683     else
 684         Perl_croak(aTHX_ "lobj is not of type version");
 685 }
 686
 687 XS(XS_version_noop)
 688 {
 689     dVAR;
 690     dXSARGS;
 691     PERL_UNUSED_ARG(cv);
 692     if (items < 1)
 693         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 694     if (sv_derived_from(ST(0), "version"))
 695         Perl_croak(aTHX_ "operation not supported with version object");
 696     else
 697         Perl_croak(aTHX_ "lobj is not of type version");
 698 #ifndef HASATTRIBUTE_NORETURN
 699     XSRETURN_EMPTY;
 700 #endif
 701 }
 702
 703 XS(XS_version_is_alpha)
 704 {
 705     dVAR;
 706     dXSARGS;
 707     PERL_UNUSED_ARG(cv);
 708     if (items != 1)
 709         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
 710     SP -= items;
 711     if (sv_derived_from(ST(0), "version")) {
 712         SV * const lobj = ST(0);
 713         if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
 714             XSRETURN_YES;
 715         else
 716             XSRETURN_NO;
 717         PUTBACK;
 718         return;
 719     }
 720     else
 721         Perl_croak(aTHX_ "lobj is not of type version");
 722 }
 723
 724 XS(XS_version_qv)
 725 {
 726     dVAR;
 727     dXSARGS;
 728     PERL_UNUSED_ARG(cv);
 729     if (items != 1)
 730         Perl_croak(aTHX_ "Usage: version::qv(ver)");
 731     SP -= items;
 732     {
 733         SV *    ver = ST(0);
 734         if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
 735             SV * const rv = sv_newmortal();
 736             sv_setsv(rv,ver); /* make a duplicate */
 737             upg_version(rv, TRUE);
 738             PUSHs(rv);
 739         }
 740         else
 741         {
 742             PUSHs(sv_2mortal(new_version(ver)));
 743         }
 744
 745         PUTBACK;
 746         return;
 747     }
 748 }
 749
 750 XS(XS_utf8_is_utf8)
 751 {
 752      dVAR;
 753      dXSARGS;
 754      PERL_UNUSED_ARG(cv);
 755      if (items != 1)
 756           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
 757      else {
 758         const SV * const sv = ST(0);
 759             if (SvUTF8(sv))
 760                 XSRETURN_YES;
 761             else
 762                 XSRETURN_NO;
 763      }
 764      XSRETURN_EMPTY;
 765 }
 766
 767 XS(XS_utf8_valid)
 768 {
 769      dVAR;
 770      dXSARGS;
 771      PERL_UNUSED_ARG(cv);
 772      if (items != 1)
 773           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 774     else {
 775         SV * const sv = ST(0);
 776         STRLEN len;
 777         const char * const s = SvPV_const(sv,len);
 778         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 779             XSRETURN_YES;
 780         else
 781             XSRETURN_NO;
 782     }
 783      XSRETURN_EMPTY;
 784 }
 785
 786 XS(XS_utf8_encode)
 787 {
 788     dVAR;
 789     dXSARGS;
 790     PERL_UNUSED_ARG(cv);
 791     if (items != 1)
 792         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 793     sv_utf8_encode(ST(0));
 794     XSRETURN_EMPTY;
 795 }
 796
 797 XS(XS_utf8_decode)
 798 {
 799     dVAR;
 800     dXSARGS;
 801     PERL_UNUSED_ARG(cv);
 802     if (items != 1)
 803         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 804     else {
 805         SV * const sv = ST(0);
 806         const bool RETVAL = sv_utf8_decode(sv);
 807         ST(0) = boolSV(RETVAL);
 808         sv_2mortal(ST(0));
 809     }
 810     XSRETURN(1);
 811 }
 812
 813 XS(XS_utf8_upgrade)
 814 {
 815     dVAR;
 816     dXSARGS;
 817     PERL_UNUSED_ARG(cv);
 818     if (items != 1)
 819         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 820     else {
 821         SV * const sv = ST(0);
 822         STRLEN  RETVAL;
 823         dXSTARG;
 824
 825         RETVAL = sv_utf8_upgrade(sv);
 826         XSprePUSH; PUSHi((IV)RETVAL);
 827     }
 828     XSRETURN(1);
 829 }
 830
 831 XS(XS_utf8_downgrade)
 832 {
 833     dVAR;
 834     dXSARGS;
 835     PERL_UNUSED_ARG(cv);
 836     if (items < 1 || items > 2)
 837         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 838     else {
 839         SV * const sv = ST(0);
 840         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 841         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 842
 843         ST(0) = boolSV(RETVAL);
 844         sv_2mortal(ST(0));
 845     }
 846     XSRETURN(1);
 847 }
 848
 849 XS(XS_utf8_native_to_unicode)
 850 {
 851  dVAR;
 852  dXSARGS;
 853  const UV uv = SvUV(ST(0));
 854  PERL_UNUSED_ARG(cv);
 855
 856  if (items > 1)
 857      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 858
 859  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 860  XSRETURN(1);
 861 }
 862
 863 XS(XS_utf8_unicode_to_native)
 864 {
 865  dVAR;
 866  dXSARGS;
 867  const UV uv = SvUV(ST(0));
 868  PERL_UNUSED_ARG(cv);
 869
 870  if (items > 1)
 871      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 872
 873  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 874  XSRETURN(1);
 875 }
 876
 877 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 878 {
 879     dVAR;
 880     dXSARGS;
 881     SV * const sv = SvRV(ST(0));
 882     PERL_UNUSED_ARG(cv);
 883
 884     if (items == 1) {
 885          if (SvREADONLY(sv))
 886              XSRETURN_YES;
 887          else
 888              XSRETURN_NO;
 889     }
 890     else if (items == 2) {
 891         if (SvTRUE(ST(1))) {
 892             SvREADONLY_on(sv);
 893             XSRETURN_YES;
 894         }
 895         else {
 896             /* I hope you really know what you are doing. */
 897             SvREADONLY_off(sv);
 898             XSRETURN_NO;
 899         }
 900     }
 901     XSRETURN_UNDEF; /* Can't happen. */
 902 }
 903
 904 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 905 {
 906     dVAR;
 907     dXSARGS;
 908     SV * const sv = SvRV(ST(0));
 909     PERL_UNUSED_ARG(cv);
 910
 911     if (items == 1)
 912          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 913     else if (items == 2) {
 914          /* I hope you really know what you are doing. */
 915          SvREFCNT(sv) = SvIV(ST(1));
 916          XSRETURN_IV(SvREFCNT(sv));
 917     }
 918     XSRETURN_UNDEF; /* Can't happen. */
 919 }
 920
 921 XS(XS_Internals_hv_clear_placehold)
 922 {
 923     dVAR;
 924     dXSARGS;
 925     PERL_UNUSED_ARG(cv);
 926
 927     if (items != 1)
 928         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
 929     else {
 930         HV * const hv = (HV *) SvRV(ST(0));
 931         hv_clear_placeholders(hv);
 932         XSRETURN(0);
 933     }
 934 }
 935
 936 XS(XS_Regexp_DESTROY)
 937 {
 938     PERL_UNUSED_CONTEXT;
 939     PERL_UNUSED_ARG(cv);
 940 }
 941
 942 XS(XS_PerlIO_get_layers)
 943 {
 944     dVAR;
 945     dXSARGS;
 946     PERL_UNUSED_ARG(cv);
 947     if (items < 1 || items % 2 == 0)
 948         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
 949 #ifdef USE_PERLIO
 950     {
 951         SV *    sv;
 952         GV *    gv;
 953         IO *    io;
 954         bool    input = TRUE;
 955         bool    details = FALSE;
 956
 957         if (items > 1) {
 958              SV * const *svp;
 959              for (svp = MARK + 2; svp <= SP; svp += 2) {
 960                   SV * const * const varp = svp;
 961                   SV * const * const valp = svp + 1;
 962                   STRLEN klen;
 963                   const char * const key = SvPV_const(*varp, klen);
 964
 965                   switch (*key) {
 966                   case 'i':
 967                        if (klen == 5 && memEQ(key, "input", 5)) {
 968                             input = SvTRUE(*valp);
 969                             break;
 970                        }
 971                        goto fail;
 972                   case 'o':
 973                        if (klen == 6 && memEQ(key, "output", 6)) {
 974                             input = !SvTRUE(*valp);
 975                             break;
 976                        }
 977                        goto fail;
 978                   case 'd':
 979                        if (klen == 7 && memEQ(key, "details", 7)) {
 980                             details = SvTRUE(*valp);
 981                             break;
 982                        }
 983                        goto fail;
 984                   default:
 985                   fail:
 986                        Perl_croak(aTHX_
 987                                   "get_layers: unknown argument '%s'",
 988                                   key);
 989                   }
 990              }
 991
 992              SP -= (items - 1);
 993         }
 994
 995         sv = POPs;
 996         gv = (GV*)sv;
 997
 998         if (!isGV(sv)) {
 999              if (SvROK(sv) && isGV(SvRV(sv)))
1000                   gv = (GV*)SvRV(sv);
1001              else if (SvPOKp(sv))
1002                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
1003         }
1004
1005         if (gv && (io = GvIO(gv))) {
1006              dTARGET;
1007              AV* const av = PerlIO_get_layers(aTHX_ input ?
1008                                         IoIFP(io) : IoOFP(io));
1009              I32 i;
1010              const I32 last = av_len(av);
1011              I32 nitem = 0;
1012
1013              for (i = last; i >= 0; i -= 3) {
1014                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1015                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1016                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
1017
1018                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1019                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1020                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1021
1022                   if (details) {
1023                        XPUSHs(namok
1024                               ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
1025                               : &PL_sv_undef);
1026                        XPUSHs(argok
1027                               ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
1028                               : &PL_sv_undef);
1029                        if (flgok)
1030                             XPUSHi(SvIVX(*flgsvp));
1031                        else
1032                             XPUSHs(&PL_sv_undef);
1033                        nitem += 3;
1034                   }
1035                   else {
1036                        if (namok && argok)
1037                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1038                                                  SVfARG(*namsvp),
1039                                                  SVfARG(*argsvp)));
1040                        else if (namok)
1041                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf,
1042                                                  SVfARG(*namsvp)));
1043                        else
1044                             XPUSHs(&PL_sv_undef);
1045                        nitem++;
1046                        if (flgok) {
1047                             const IV flags = SvIVX(*flgsvp);
1048
1049                             if (flags & PERLIO_F_UTF8) {
1050                                  XPUSHs(newSVpvs("utf8"));
1051                                  nitem++;
1052                             }
1053                        }
1054                   }
1055              }
1056
1057              SvREFCNT_dec(av);
1058
1059              XSRETURN(nitem);
1060         }
1061     }
1062 #endif
1063
1064     XSRETURN(0);
1065 }
1066
1067 XS(XS_Internals_hash_seed)
1068 {
1069     dVAR;
1070     /* Using dXSARGS would also have dITEM and dSP,
1071      * which define 2 unused local variables.  */
1072     dAXMARK;
1073     PERL_UNUSED_ARG(cv);
1074     PERL_UNUSED_VAR(mark);
1075     XSRETURN_UV(PERL_HASH_SEED);
1076 }
1077
1078 XS(XS_Internals_rehash_seed)
1079 {
1080     dVAR;
1081     /* Using dXSARGS would also have dITEM and dSP,
1082      * which define 2 unused local variables.  */
1083     dAXMARK;
1084     PERL_UNUSED_ARG(cv);
1085     PERL_UNUSED_VAR(mark);
1086     XSRETURN_UV(PL_rehash_seed);
1087 }
1088
1089 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1090 {
1091     dVAR;
1092     dXSARGS;
1093     PERL_UNUSED_ARG(cv);
1094     if (SvROK(ST(0))) {
1095         const HV * const hv = (HV *) SvRV(ST(0));
1096         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1097             if (HvREHASH(hv))
1098                 XSRETURN_YES;
1099             else
1100                 XSRETURN_NO;
1101         }
1102     }
1103     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1104 }
1105
1106 XS(XS_Internals_inc_sub_generation)
1107 {
1108     dVAR;
1109     /* Using dXSARGS would also have dITEM and dSP,
1110      * which define 2 unused local variables.  */
1111     dAXMARK;
1112     PERL_UNUSED_ARG(cv);
1113     PERL_UNUSED_VAR(mark);
1114     ++PL_sub_generation;
1115     XSRETURN_EMPTY;
1116 }
1117
1118 XS(XS_re_is_regexp)
1119 {
1120     dVAR;
1121     dXSARGS;
1122     if (items != 1)
1123        Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
1124     PERL_UNUSED_VAR(cv); /* -W */
1125     PERL_UNUSED_VAR(ax); /* -Wall */
1126     SP -= items;
1127     {
1128         SV *    sv = ST(0);
1129         if ( Perl_get_re_arg( aTHX_ sv, 0, NULL ) )
1130         {
1131             XSRETURN_YES;
1132         } else {
1133             XSRETURN_NO;
1134         }
1135         /* NOTREACHED */
1136         PUTBACK;
1137         return;
1138     }
1139 }
1140
1141 XS(XS_re_regname)
1142 {
1143
1144     dVAR;
1145     dXSARGS;
1146     if (items < 1 || items > 2)
1147        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1148     PERL_UNUSED_VAR(cv); /* -W */
1149     PERL_UNUSED_VAR(ax); /* -Wall */
1150     SP -= items;
1151     {
1152         SV *    sv = ST(0);
1153         SV *    all;
1154         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1155         SV *bufs = NULL;
1156
1157         if (items < 2)
1158             all = NULL;
1159         else {
1160             all = ST(1);
1161         }
1162         {
1163             if (SvPOK(sv) && re && re->paren_names) {
1164                 bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all));
1165                 if (bufs) {
1166                     if (all && SvTRUE(all))
1167                         XPUSHs(newRV(bufs));
1168                     else
1169                         XPUSHs(SvREFCNT_inc(bufs));
1170                     XSRETURN(1);
1171                 }
1172             }
1173             XSRETURN_UNDEF;
1174         }
1175         PUTBACK;
1176         return;
1177     }
1178 }
1179
1180 XS(XS_re_regnames)
1181 {
1182     dVAR;
1183     dXSARGS;
1184     if (items < 0 || items > 1)
1185        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
1186     PERL_UNUSED_VAR(cv); /* -W */
1187     PERL_UNUSED_VAR(ax); /* -Wall */
1188     SP -= items;
1189     {
1190         SV *    all;
1191         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1192         IV count = 0;
1193
1194         if (items < 1)
1195             all = NULL;
1196         else {
1197             all = ST(0);
1198         }
1199         {
1200             if (re && re->paren_names) {
1201                 HV *hv= re->paren_names;
1202                 (void)hv_iterinit(hv);
1203                 while (1) {
1204                     HE *temphe = hv_iternext_flags(hv,0);
1205                     if (temphe) {
1206                         IV i;
1207                         IV parno = 0;
1208                         SV* sv_dat = HeVAL(temphe);
1209                         I32 *nums = (I32*)SvPVX(sv_dat);
1210                         for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1211                             if ((I32)(re->lastcloseparen) >= nums[i] &&
1212                                 re->startp[nums[i]] != -1 &&
1213                                 re->endp[nums[i]] != -1)
1214                             {
1215                                 parno = nums[i];
1216                                 break;
1217                             }
1218                         }
1219                         if (parno || (all && SvTRUE(all))) {
1220                             STRLEN len;
1221                             char *pv = HePV(temphe, len);
1222                             if ( GIMME_V == G_ARRAY )
1223                                 XPUSHs(newSVpvn(pv,len));
1224                             count++;
1225                         }
1226                     } else {
1227                         break;
1228                     }
1229                 }
1230             }
1231             if ( GIMME_V == G_ARRAY )
1232                 XSRETURN(count);
1233             else
1234                 XSRETURN_UNDEF;
1235         }
1236         PUTBACK;
1237         return;
1238     }
1239 }
1240
1241
1242 XS(XS_re_regnames_iterinit)
1243 {
1244     dVAR;
1245     dXSARGS;
1246     if (items != 0)
1247         Perl_croak(aTHX_ "Usage: re::regnames_iterinit()");
1248     PERL_UNUSED_VAR(cv); /* -W */
1249     PERL_UNUSED_VAR(ax); /* -Wall */
1250     SP -= items;
1251     {
1252         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1253         if (re && re->paren_names) {
1254             (void)hv_iterinit(re->paren_names);
1255             XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1256         } else {
1257             XSRETURN_UNDEF;
1258         }
1259         PUTBACK;
1260         return;
1261     }
1262 }
1263
1264
1265 XS(XS_re_regnames_iternext)
1266 {
1267     dVAR;
1268     dXSARGS;
1269     if (items < 0 || items > 1)
1270        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "[all]");
1271     PERL_UNUSED_VAR(cv); /* -W */
1272     PERL_UNUSED_VAR(ax); /* -Wall */
1273     SP -= items;
1274     {
1275         SV *    all;
1276         regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1277
1278         if (items < 1)
1279             all = NULL;
1280         else {
1281             all = ST(0);
1282         }
1283         if (re && re->paren_names) {
1284             HV *hv= re->paren_names;
1285             while (1) {
1286                 HE *temphe = hv_iternext_flags(hv,0);
1287                 if (temphe) {
1288                     IV i;
1289                     IV parno = 0;
1290                     SV* sv_dat = HeVAL(temphe);
1291                     I32 *nums = (I32*)SvPVX(sv_dat);
1292                     for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1293                         if ((I32)(re->lastcloseparen) >= nums[i] &&
1294                             re->startp[nums[i]] != -1 &&
1295                             re->endp[nums[i]] != -1)
1296                         {
1297                             parno = nums[i];
1298                             break;
1299                         }
1300                     }
1301                     if (parno || (all && SvTRUE(all))) {
1302                         STRLEN len;
1303                         char *pv = HePV(temphe, len);
1304                         XPUSHs(newSVpvn(pv,len));
1305                         XSRETURN(1);
1306                     }
1307                 } else {
1308                     break;
1309                 }
1310             }
1311         }
1312         XSRETURN_UNDEF;
1313         PUTBACK;
1314         return;
1315     }
1316 }
1317
1318
1319 XS(XS_re_regnames_count)
1320 {
1321     regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1322     dVAR;
1323     dXSARGS;
1324
1325     if (items != 0)
1326        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1327     PERL_UNUSED_VAR(cv); /* -W */
1328     PERL_UNUSED_VAR(ax); /* -Wall */
1329     SP -= items;
1330
1331     if (re && re->paren_names) {
1332         XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1333     } else {
1334         XSRETURN_UNDEF;
1335     }
1336     PUTBACK;
1337     return;
1338 }
1339
1340
1341 /*
1342  * Local variables:
1343  * c-indentation-style: bsd
1344  * c-basic-offset: 4
1345  * indent-tabs-mode: t
1346  * End:
1347  *
1348  * ex: set ts=8 sts=4 sw=4 noet:
1349  */