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  * It is also used to store XS functions that need to be present in
  21  * miniperl for a lack of a better place to put them. It might be
  22  * clever to move them to seperate XS files which would then be pulled
  23  * in by some to-be-written build process.
  24  */
  25
  26 #include "EXTERN.h"
  27 #define PERL_IN_UNIVERSAL_C
  28 #include "perl.h"
  29
  30 #ifdef USE_PERLIO
  31 #include "perliol.h" /* For the PERLIO_F_XXX */
  32 #endif
  33
  34 /*
  35  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  36  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  37  */
  38
  39 STATIC bool
  40 S_isa_lookup(pTHX_ HV *stash, const char * const name, const HV* const name_stash)
  41 {
  42     dVAR;
  43     AV* stash_linear_isa;
  44     SV** svp;
  45     const char *hvname;
  46     I32 items;
  47
  48     /* A stash/class can go by many names (ie. User == main::User), so
  49        we compare the stash itself just in case */
  50     if (name_stash && ((const HV *)stash == name_stash))
  51         return TRUE;
  52
  53     hvname = HvNAME_get(stash);
  54
  55     if (strEQ(hvname, name))
  56         return TRUE;
  57
  58     if (strEQ(name, "UNIVERSAL"))
  59         return TRUE;
  60
  61     stash_linear_isa = mro_get_linear_isa(stash);
  62     svp = AvARRAY(stash_linear_isa) + 1;
  63     items = AvFILLp(stash_linear_isa);
  64     while (items--) {
  65         SV* const basename_sv = *svp++;
  66         HV* const basestash = gv_stashsv(basename_sv, 0);
  67         if (!basestash) {
  68             if (ckWARN(WARN_SYNTAX))
  69                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
  70                             "Can't locate package %"SVf" for the parents of %s",
  71                             SVfARG(basename_sv), hvname);
  72             continue;
  73         }
  74         if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
  75             return TRUE;
  76     }
  77
  78     return FALSE;
  79 }
  80
  81 /*
  82 =head1 SV Manipulation Functions
  83
  84 =for apidoc sv_derived_from
  85
  86 Returns a boolean indicating whether the SV is derived from the specified class
  87 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
  88 normal Perl method.
  89
  90 =cut
  91 */
  92
  93 bool
  94 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
  95 {
  96     dVAR;
  97     HV *stash;
  98
  99     SvGETMAGIC(sv);
 100
 101     if (SvROK(sv)) {
 102         const char *type;
 103         sv = SvRV(sv);
 104         type = sv_reftype(sv,0);
 105         if (type && strEQ(type,name))
 106             return TRUE;
 107         stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
 108     }
 109     else {
 110         stash = gv_stashsv(sv, 0);
 111     }
 112
 113     if (stash) {
 114         HV * const name_stash = gv_stashpv(name, 0);
 115         return isa_lookup(stash, name, name_stash);
 116     }
 117     else
 118         return FALSE;
 119
 120 }
 121
 122 /*
 123 =for apidoc sv_does
 124
 125 Returns a boolean indicating whether the SV performs a specific, named role.
 126 The SV can be a Perl object or the name of a Perl class.
 127
 128 =cut
 129 */
 130
 131 #include "XSUB.h"
 132
 133 bool
 134 Perl_sv_does(pTHX_ SV *sv, const char *name)
 135 {
 136     const char *classname;
 137     bool does_it;
 138     SV *methodname;
 139
 140     dSP;
 141     ENTER;
 142     SAVETMPS;
 143
 144     SvGETMAGIC(sv);
 145
 146     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 147                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 148         return FALSE;
 149
 150     if (sv_isobject(sv)) {
 151         classname = sv_reftype(SvRV(sv),TRUE);
 152     } else {
 153         classname = SvPV_nolen(sv);
 154     }
 155
 156     if (strEQ(name,classname))
 157         return TRUE;
 158
 159     PUSHMARK(SP);
 160     XPUSHs(sv);
 161     mXPUSHs(newSVpv(name, 0));
 162     PUTBACK;
 163
 164     methodname = newSVpvs_flags("isa", SVs_TEMP);
 165     /* ugly hack: use the SvSCREAM flag so S_method_common
 166      * can figure out we're calling DOES() and not isa(),
 167      * and report eventual errors correctly. --rgs */
 168     SvSCREAM_on(methodname);
 169     call_sv(methodname, G_SCALAR | G_METHOD);
 170     SPAGAIN;
 171
 172     does_it = SvTRUE( TOPs );
 173     FREETMPS;
 174     LEAVE;
 175
 176     return does_it;
 177 }
 178
 179 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
 180 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
 181 PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
 182 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
 183 XS(XS_version_new);
 184 XS(XS_version_stringify);
 185 XS(XS_version_numify);
 186 XS(XS_version_normal);
 187 XS(XS_version_vcmp);
 188 XS(XS_version_boolean);
 189 #ifdef HASATTRIBUTE_NORETURN
 190 XS(XS_version_noop) __attribute__noreturn__;
 191 #else
 192 XS(XS_version_noop);
 193 #endif
 194 XS(XS_version_is_alpha);
 195 XS(XS_version_qv);
 196 XS(XS_utf8_is_utf8);
 197 XS(XS_utf8_valid);
 198 XS(XS_utf8_encode);
 199 XS(XS_utf8_decode);
 200 XS(XS_utf8_upgrade);
 201 XS(XS_utf8_downgrade);
 202 XS(XS_utf8_unicode_to_native);
 203 XS(XS_utf8_native_to_unicode);
 204 XS(XS_Internals_SvREADONLY);
 205 XS(XS_Internals_SvREFCNT);
 206 XS(XS_Internals_hv_clear_placehold);
 207 XS(XS_PerlIO_get_layers);
 208 XS(XS_Regexp_DESTROY);
 209 XS(XS_Internals_hash_seed);
 210 XS(XS_Internals_rehash_seed);
 211 XS(XS_Internals_HvREHASH);
 212 XS(XS_Internals_inc_sub_generation);
 213 XS(XS_re_is_regexp);
 214 XS(XS_re_regname);
 215 XS(XS_re_regnames);
 216 XS(XS_re_regnames_count);
 217 XS(XS_re_regexp_pattern);
 218 XS(XS_Tie_Hash_NamedCapture_FETCH);
 219 XS(XS_Tie_Hash_NamedCapture_STORE);
 220 XS(XS_Tie_Hash_NamedCapture_DELETE);
 221 XS(XS_Tie_Hash_NamedCapture_CLEAR);
 222 XS(XS_Tie_Hash_NamedCapture_EXISTS);
 223 XS(XS_Tie_Hash_NamedCapture_FIRSTK);
 224 XS(XS_Tie_Hash_NamedCapture_NEXTK);
 225 XS(XS_Tie_Hash_NamedCapture_SCALAR);
 226 XS(XS_Tie_Hash_NamedCapture_flags);
 227
 228 void
 229 Perl_boot_core_UNIVERSAL(pTHX)
 230 {
 231     dVAR;
 232     static const char file[] = __FILE__;
 233
 234     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
 235     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
 236     newXS("UNIVERSAL::DOES",            XS_UNIVERSAL_DOES,        file);
 237     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
 238     {
 239         /* register the overloading (type 'A') magic */
 240         PL_amagic_generation++;
 241         /* Make it findable via fetchmethod */
 242         newXS("version::()", XS_version_noop, file);
 243         newXS("version::new", XS_version_new, file);
 244         newXS("version::(\"\"", XS_version_stringify, file);
 245         newXS("version::stringify", XS_version_stringify, file);
 246         newXS("version::(0+", XS_version_numify, file);
 247         newXS("version::numify", XS_version_numify, file);
 248         newXS("version::normal", XS_version_normal, file);
 249         newXS("version::(cmp", XS_version_vcmp, file);
 250         newXS("version::(<=>", XS_version_vcmp, file);
 251         newXS("version::vcmp", XS_version_vcmp, file);
 252         newXS("version::(bool", XS_version_boolean, file);
 253         newXS("version::boolean", XS_version_boolean, file);
 254         newXS("version::(nomethod", XS_version_noop, file);
 255         newXS("version::noop", XS_version_noop, file);
 256         newXS("version::is_alpha", XS_version_is_alpha, file);
 257         newXS("version::qv", XS_version_qv, file);
 258     }
 259     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
 260     newXS("utf8::valid", XS_utf8_valid, file);
 261     newXS("utf8::encode", XS_utf8_encode, file);
 262     newXS("utf8::decode", XS_utf8_decode, file);
 263     newXS("utf8::upgrade", XS_utf8_upgrade, file);
 264     newXS("utf8::downgrade", XS_utf8_downgrade, file);
 265     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
 266     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
 267     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
 268     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 269     newXSproto("Internals::hv_clear_placeholders",
 270                XS_Internals_hv_clear_placehold, file, "\\%");
 271     newXSproto("PerlIO::get_layers",
 272                XS_PerlIO_get_layers, file, "*;@");
 273     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
 274     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
 275     newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
 276     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
 277     newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
 278     newXSproto("re::regname", XS_re_regname, file, ";$$");
 279     newXSproto("re::regnames", XS_re_regnames, file, ";$");
 280     newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
 281     newXSproto("re::regexp_pattern", XS_re_regexp_pattern, file, "$");
 282     newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
 283     newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
 284     newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
 285     newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file);
 286     newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file);
 287     newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, file);
 288     newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, file);
 289     newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file);
 290     newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file);
 291 }
 292
 293
 294 XS(XS_UNIVERSAL_isa)
 295 {
 296     dVAR;
 297     dXSARGS;
 298     PERL_UNUSED_ARG(cv);
 299
 300     if (items != 2)
 301         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 302     else {
 303         SV * const sv = ST(0);
 304         const char *name;
 305
 306         SvGETMAGIC(sv);
 307
 308         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 309                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 310             XSRETURN_UNDEF;
 311
 312         name = SvPV_nolen_const(ST(1));
 313
 314         ST(0) = boolSV(sv_derived_from(sv, name));
 315         XSRETURN(1);
 316     }
 317 }
 318
 319 XS(XS_UNIVERSAL_can)
 320 {
 321     dVAR;
 322     dXSARGS;
 323     SV   *sv;
 324     const char *name;
 325     SV   *rv;
 326     HV   *pkg = NULL;
 327     PERL_UNUSED_ARG(cv);
 328
 329     if (items != 2)
 330         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 331
 332     sv = ST(0);
 333
 334     SvGETMAGIC(sv);
 335
 336     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 337                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 338         XSRETURN_UNDEF;
 339
 340     name = SvPV_nolen_const(ST(1));
 341     rv = &PL_sv_undef;
 342
 343     if (SvROK(sv)) {
 344         sv = (SV*)SvRV(sv);
 345         if (SvOBJECT(sv))
 346             pkg = SvSTASH(sv);
 347     }
 348     else {
 349         pkg = gv_stashsv(sv, 0);
 350     }
 351
 352     if (pkg) {
 353         GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 354         if (gv && isGV(gv))
 355             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 356     }
 357
 358     ST(0) = rv;
 359     XSRETURN(1);
 360 }
 361
 362 XS(XS_UNIVERSAL_DOES)
 363 {
 364     dVAR;
 365     dXSARGS;
 366     PERL_UNUSED_ARG(cv);
 367
 368     if (items != 2)
 369         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
 370     else {
 371         SV * const sv = ST(0);
 372         const char *name;
 373
 374         name = SvPV_nolen_const(ST(1));
 375         if (sv_does( sv, name ))
 376             XSRETURN_YES;
 377
 378         XSRETURN_NO;
 379     }
 380 }
 381
 382 XS(XS_UNIVERSAL_VERSION)
 383 {
 384     dVAR;
 385     dXSARGS;
 386     HV *pkg;
 387     GV **gvp;
 388     GV *gv;
 389     SV *sv;
 390     const char *undef;
 391     PERL_UNUSED_ARG(cv);
 392
 393     if (SvROK(ST(0))) {
 394         sv = (SV*)SvRV(ST(0));
 395         if (!SvOBJECT(sv))
 396             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 397         pkg = SvSTASH(sv);
 398     }
 399     else {
 400         pkg = gv_stashsv(ST(0), 0);
 401     }
 402
 403     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
 404
 405     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 406         SV * const nsv = sv_newmortal();
 407         sv_setsv(nsv, sv);
 408         sv = nsv;
 409         if ( !sv_derived_from(sv, "version"))
 410             upg_version(sv, FALSE);
 411         undef = NULL;
 412     }
 413     else {
 414         sv = (SV*)&PL_sv_undef;
 415         undef = "(undef)";
 416     }
 417
 418     if (items > 1) {
 419         SV *req = ST(1);
 420
 421         if (undef) {
 422             if (pkg) {
 423                 const char * const name = HvNAME_get(pkg);
 424                 Perl_croak(aTHX_
 425                            "%s does not define $%s::VERSION--version check failed",
 426                            name, name);
 427             } else {
 428                 Perl_croak(aTHX_
 429                              "%s defines neither package nor VERSION--version check failed",
 430                              SvPVx_nolen_const(ST(0)) );
 431              }
 432         }
 433
 434         if ( !sv_derived_from(req, "version")) {
 435             /* req may very well be R/O, so create a new object */
 436             req = sv_2mortal( new_version(req) );
 437         }
 438
 439         if ( vcmp( req, sv ) > 0 ) {
 440             if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) {
 441                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 442                        "this is only version %"SVf"", HvNAME_get(pkg),
 443                        SVfARG(vnormal(req)),
 444                        SVfARG(vnormal(sv)));
 445             } else {
 446                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 447                        "this is only version %"SVf"", HvNAME_get(pkg),
 448                        SVfARG(vstringify(req)),
 449                        SVfARG(vstringify(sv)));
 450             }
 451         }
 452
 453     }
 454
 455     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
 456         ST(0) = vstringify(sv);
 457     } else {
 458         ST(0) = sv;
 459     }
 460
 461     XSRETURN(1);
 462 }
 463
 464 XS(XS_version_new)
 465 {
 466     dVAR;
 467     dXSARGS;
 468     PERL_UNUSED_ARG(cv);
 469     if (items > 3)
 470         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 471     SP -= items;
 472     {
 473         SV *vs = ST(1);
 474         SV *rv;
 475         const char * const classname =
 476             sv_isobject(ST(0)) /* get the class if called as an object method */
 477                 ? HvNAME(SvSTASH(SvRV(ST(0))))
 478                 : (char *)SvPV_nolen(ST(0));
 479
 480         if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
 481             /* create empty object */
 482             vs = sv_newmortal();
 483             sv_setpvn(vs,"",0);
 484         }
 485         else if ( items == 3 ) {
 486             vs = sv_newmortal();
 487             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 488         }
 489
 490         rv = new_version(vs);
 491         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
 492             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 493
 494         mPUSHs(rv);
 495         PUTBACK;
 496         return;
 497     }
 498 }
 499
 500 XS(XS_version_stringify)
 501 {
 502      dVAR;
 503      dXSARGS;
 504      PERL_UNUSED_ARG(cv);
 505      if (items < 1)
 506           Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
 507      SP -= items;
 508      {
 509           SV *  lobj;
 510
 511           if (sv_derived_from(ST(0), "version")) {
 512                lobj = SvRV(ST(0));
 513           }
 514           else
 515                Perl_croak(aTHX_ "lobj is not of type version");
 516
 517           mPUSHs(vstringify(lobj));
 518
 519           PUTBACK;
 520           return;
 521      }
 522 }
 523
 524 XS(XS_version_numify)
 525 {
 526      dVAR;
 527      dXSARGS;
 528      PERL_UNUSED_ARG(cv);
 529      if (items < 1)
 530           Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
 531      SP -= items;
 532      {
 533           SV *  lobj;
 534
 535           if (sv_derived_from(ST(0), "version")) {
 536                lobj = SvRV(ST(0));
 537           }
 538           else
 539                Perl_croak(aTHX_ "lobj is not of type version");
 540
 541           mPUSHs(vnumify(lobj));
 542
 543           PUTBACK;
 544           return;
 545      }
 546 }
 547
 548 XS(XS_version_normal)
 549 {
 550      dVAR;
 551      dXSARGS;
 552      PERL_UNUSED_ARG(cv);
 553      if (items < 1)
 554           Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
 555      SP -= items;
 556      {
 557           SV *  lobj;
 558
 559           if (sv_derived_from(ST(0), "version")) {
 560                lobj = SvRV(ST(0));
 561           }
 562           else
 563                Perl_croak(aTHX_ "lobj is not of type version");
 564
 565           mPUSHs(vnormal(lobj));
 566
 567           PUTBACK;
 568           return;
 569      }
 570 }
 571
 572 XS(XS_version_vcmp)
 573 {
 574      dVAR;
 575      dXSARGS;
 576      PERL_UNUSED_ARG(cv);
 577      if (items < 1)
 578           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 579      SP -= items;
 580      {
 581           SV *  lobj;
 582
 583           if (sv_derived_from(ST(0), "version")) {
 584                lobj = SvRV(ST(0));
 585           }
 586           else
 587                Perl_croak(aTHX_ "lobj is not of type version");
 588
 589           {
 590                SV       *rs;
 591                SV       *rvs;
 592                SV * robj = ST(1);
 593                const IV  swap = (IV)SvIV(ST(2));
 594
 595                if ( ! sv_derived_from(robj, "version") )
 596                {
 597                     robj = new_version(robj);
 598                }
 599                rvs = SvRV(robj);
 600
 601                if ( swap )
 602                {
 603                     rs = newSViv(vcmp(rvs,lobj));
 604                }
 605                else
 606                {
 607                     rs = newSViv(vcmp(lobj,rvs));
 608                }
 609
 610                mPUSHs(rs);
 611           }
 612
 613           PUTBACK;
 614           return;
 615      }
 616 }
 617
 618 XS(XS_version_boolean)
 619 {
 620     dVAR;
 621     dXSARGS;
 622     PERL_UNUSED_ARG(cv);
 623     if (items < 1)
 624         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 625     SP -= items;
 626     if (sv_derived_from(ST(0), "version")) {
 627         SV * const lobj = SvRV(ST(0));
 628         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
 629         mPUSHs(rs);
 630         PUTBACK;
 631         return;
 632     }
 633     else
 634         Perl_croak(aTHX_ "lobj is not of type version");
 635 }
 636
 637 XS(XS_version_noop)
 638 {
 639     dVAR;
 640     dXSARGS;
 641     PERL_UNUSED_ARG(cv);
 642     if (items < 1)
 643         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 644     if (sv_derived_from(ST(0), "version"))
 645         Perl_croak(aTHX_ "operation not supported with version object");
 646     else
 647         Perl_croak(aTHX_ "lobj is not of type version");
 648 #ifndef HASATTRIBUTE_NORETURN
 649     XSRETURN_EMPTY;
 650 #endif
 651 }
 652
 653 XS(XS_version_is_alpha)
 654 {
 655     dVAR;
 656     dXSARGS;
 657     PERL_UNUSED_ARG(cv);
 658     if (items != 1)
 659         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
 660     SP -= items;
 661     if (sv_derived_from(ST(0), "version")) {
 662         SV * const lobj = ST(0);
 663         if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
 664             XSRETURN_YES;
 665         else
 666             XSRETURN_NO;
 667         PUTBACK;
 668         return;
 669     }
 670     else
 671         Perl_croak(aTHX_ "lobj is not of type version");
 672 }
 673
 674 XS(XS_version_qv)
 675 {
 676     dVAR;
 677     dXSARGS;
 678     PERL_UNUSED_ARG(cv);
 679     if (items != 1)
 680         Perl_croak(aTHX_ "Usage: version::qv(ver)");
 681     SP -= items;
 682     {
 683         SV *    ver = ST(0);
 684         if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
 685             SV * const rv = sv_newmortal();
 686             sv_setsv(rv,ver); /* make a duplicate */
 687             upg_version(rv, TRUE);
 688             PUSHs(rv);
 689         }
 690         else
 691         {
 692             mPUSHs(new_version(ver));
 693         }
 694
 695         PUTBACK;
 696         return;
 697     }
 698 }
 699
 700 XS(XS_utf8_is_utf8)
 701 {
 702      dVAR;
 703      dXSARGS;
 704      PERL_UNUSED_ARG(cv);
 705      if (items != 1)
 706           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
 707      else {
 708         const SV * const sv = ST(0);
 709             if (SvUTF8(sv))
 710                 XSRETURN_YES;
 711             else
 712                 XSRETURN_NO;
 713      }
 714      XSRETURN_EMPTY;
 715 }
 716
 717 XS(XS_utf8_valid)
 718 {
 719      dVAR;
 720      dXSARGS;
 721      PERL_UNUSED_ARG(cv);
 722      if (items != 1)
 723           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 724     else {
 725         SV * const sv = ST(0);
 726         STRLEN len;
 727         const char * const s = SvPV_const(sv,len);
 728         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 729             XSRETURN_YES;
 730         else
 731             XSRETURN_NO;
 732     }
 733      XSRETURN_EMPTY;
 734 }
 735
 736 XS(XS_utf8_encode)
 737 {
 738     dVAR;
 739     dXSARGS;
 740     PERL_UNUSED_ARG(cv);
 741     if (items != 1)
 742         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 743     sv_utf8_encode(ST(0));
 744     XSRETURN_EMPTY;
 745 }
 746
 747 XS(XS_utf8_decode)
 748 {
 749     dVAR;
 750     dXSARGS;
 751     PERL_UNUSED_ARG(cv);
 752     if (items != 1)
 753         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 754     else {
 755         SV * const sv = ST(0);
 756         const bool RETVAL = sv_utf8_decode(sv);
 757         ST(0) = boolSV(RETVAL);
 758         sv_2mortal(ST(0));
 759     }
 760     XSRETURN(1);
 761 }
 762
 763 XS(XS_utf8_upgrade)
 764 {
 765     dVAR;
 766     dXSARGS;
 767     PERL_UNUSED_ARG(cv);
 768     if (items != 1)
 769         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 770     else {
 771         SV * const sv = ST(0);
 772         STRLEN  RETVAL;
 773         dXSTARG;
 774
 775         RETVAL = sv_utf8_upgrade(sv);
 776         XSprePUSH; PUSHi((IV)RETVAL);
 777     }
 778     XSRETURN(1);
 779 }
 780
 781 XS(XS_utf8_downgrade)
 782 {
 783     dVAR;
 784     dXSARGS;
 785     PERL_UNUSED_ARG(cv);
 786     if (items < 1 || items > 2)
 787         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 788     else {
 789         SV * const sv = ST(0);
 790         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 791         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 792
 793         ST(0) = boolSV(RETVAL);
 794         sv_2mortal(ST(0));
 795     }
 796     XSRETURN(1);
 797 }
 798
 799 XS(XS_utf8_native_to_unicode)
 800 {
 801  dVAR;
 802  dXSARGS;
 803  const UV uv = SvUV(ST(0));
 804  PERL_UNUSED_ARG(cv);
 805
 806  if (items > 1)
 807      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 808
 809  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 810  XSRETURN(1);
 811 }
 812
 813 XS(XS_utf8_unicode_to_native)
 814 {
 815  dVAR;
 816  dXSARGS;
 817  const UV uv = SvUV(ST(0));
 818  PERL_UNUSED_ARG(cv);
 819
 820  if (items > 1)
 821      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 822
 823  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 824  XSRETURN(1);
 825 }
 826
 827 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 828 {
 829     dVAR;
 830     dXSARGS;
 831     SV * const sv = SvRV(ST(0));
 832     PERL_UNUSED_ARG(cv);
 833
 834     if (items == 1) {
 835          if (SvREADONLY(sv))
 836              XSRETURN_YES;
 837          else
 838              XSRETURN_NO;
 839     }
 840     else if (items == 2) {
 841         if (SvTRUE(ST(1))) {
 842             SvREADONLY_on(sv);
 843             XSRETURN_YES;
 844         }
 845         else {
 846             /* I hope you really know what you are doing. */
 847             SvREADONLY_off(sv);
 848             XSRETURN_NO;
 849         }
 850     }
 851     XSRETURN_UNDEF; /* Can't happen. */
 852 }
 853
 854 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 855 {
 856     dVAR;
 857     dXSARGS;
 858     SV * const sv = SvRV(ST(0));
 859     PERL_UNUSED_ARG(cv);
 860
 861     if (items == 1)
 862          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 863     else if (items == 2) {
 864          /* I hope you really know what you are doing. */
 865          SvREFCNT(sv) = SvIV(ST(1));
 866          XSRETURN_IV(SvREFCNT(sv));
 867     }
 868     XSRETURN_UNDEF; /* Can't happen. */
 869 }
 870
 871 XS(XS_Internals_hv_clear_placehold)
 872 {
 873     dVAR;
 874     dXSARGS;
 875     PERL_UNUSED_ARG(cv);
 876
 877     if (items != 1)
 878         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
 879     else {
 880         HV * const hv = (HV *) SvRV(ST(0));
 881         hv_clear_placeholders(hv);
 882         XSRETURN(0);
 883     }
 884 }
 885
 886 XS(XS_Regexp_DESTROY)
 887 {
 888     PERL_UNUSED_CONTEXT;
 889     PERL_UNUSED_ARG(cv);
 890 }
 891
 892 XS(XS_PerlIO_get_layers)
 893 {
 894     dVAR;
 895     dXSARGS;
 896     PERL_UNUSED_ARG(cv);
 897     if (items < 1 || items % 2 == 0)
 898         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
 899 #ifdef USE_PERLIO
 900     {
 901         SV *    sv;
 902         GV *    gv;
 903         IO *    io;
 904         bool    input = TRUE;
 905         bool    details = FALSE;
 906
 907         if (items > 1) {
 908              SV * const *svp;
 909              for (svp = MARK + 2; svp <= SP; svp += 2) {
 910                   SV * const * const varp = svp;
 911                   SV * const * const valp = svp + 1;
 912                   STRLEN klen;
 913                   const char * const key = SvPV_const(*varp, klen);
 914
 915                   switch (*key) {
 916                   case 'i':
 917                        if (klen == 5 && memEQ(key, "input", 5)) {
 918                             input = SvTRUE(*valp);
 919                             break;
 920                        }
 921                        goto fail;
 922                   case 'o':
 923                        if (klen == 6 && memEQ(key, "output", 6)) {
 924                             input = !SvTRUE(*valp);
 925                             break;
 926                        }
 927                        goto fail;
 928                   case 'd':
 929                        if (klen == 7 && memEQ(key, "details", 7)) {
 930                             details = SvTRUE(*valp);
 931                             break;
 932                        }
 933                        goto fail;
 934                   default:
 935                   fail:
 936                        Perl_croak(aTHX_
 937                                   "get_layers: unknown argument '%s'",
 938                                   key);
 939                   }
 940              }
 941
 942              SP -= (items - 1);
 943         }
 944
 945         sv = POPs;
 946         gv = (GV*)sv;
 947
 948         if (!isGV(sv)) {
 949              if (SvROK(sv) && isGV(SvRV(sv)))
 950                   gv = (GV*)SvRV(sv);
 951              else if (SvPOKp(sv))
 952                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
 953         }
 954
 955         if (gv && (io = GvIO(gv))) {
 956              AV* const av = PerlIO_get_layers(aTHX_ input ?
 957                                         IoIFP(io) : IoOFP(io));
 958              I32 i;
 959              const I32 last = av_len(av);
 960              I32 nitem = 0;
 961
 962              for (i = last; i >= 0; i -= 3) {
 963                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 964                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 965                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 966
 967                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 968                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 969                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 970
 971                   if (details) {
 972                        XPUSHs(namok
 973                               ? sv_2mortal(newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp)))
 974                               : &PL_sv_undef);
 975                        XPUSHs(argok
 976                               ? sv_2mortal(newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp)))
 977                               : &PL_sv_undef);
 978                        if (flgok)
 979                             mXPUSHi(SvIVX(*flgsvp));
 980                        else
 981                             XPUSHs(&PL_sv_undef);
 982                        nitem += 3;
 983                   }
 984                   else {
 985                        if (namok && argok)
 986                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 987                                                  SVfARG(*namsvp),
 988                                                  SVfARG(*argsvp))));
 989                        else if (namok)
 990                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf,
 991                                                  SVfARG(*namsvp))));
 992                        else
 993                             XPUSHs(&PL_sv_undef);
 994                        nitem++;
 995                        if (flgok) {
 996                             const IV flags = SvIVX(*flgsvp);
 997
 998                             if (flags & PERLIO_F_UTF8) {
 999                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1000                                  nitem++;
1001                             }
1002                        }
1003                   }
1004              }
1005
1006              SvREFCNT_dec(av);
1007
1008              XSRETURN(nitem);
1009         }
1010     }
1011 #endif
1012
1013     XSRETURN(0);
1014 }
1015
1016 XS(XS_Internals_hash_seed)
1017 {
1018     dVAR;
1019     /* Using dXSARGS would also have dITEM and dSP,
1020      * which define 2 unused local variables.  */
1021     dAXMARK;
1022     PERL_UNUSED_ARG(cv);
1023     PERL_UNUSED_VAR(mark);
1024     XSRETURN_UV(PERL_HASH_SEED);
1025 }
1026
1027 XS(XS_Internals_rehash_seed)
1028 {
1029     dVAR;
1030     /* Using dXSARGS would also have dITEM and dSP,
1031      * which define 2 unused local variables.  */
1032     dAXMARK;
1033     PERL_UNUSED_ARG(cv);
1034     PERL_UNUSED_VAR(mark);
1035     XSRETURN_UV(PL_rehash_seed);
1036 }
1037
1038 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1039 {
1040     dVAR;
1041     dXSARGS;
1042     PERL_UNUSED_ARG(cv);
1043     if (SvROK(ST(0))) {
1044         const HV * const hv = (HV *) SvRV(ST(0));
1045         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1046             if (HvREHASH(hv))
1047                 XSRETURN_YES;
1048             else
1049                 XSRETURN_NO;
1050         }
1051     }
1052     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1053 }
1054
1055 XS(XS_re_is_regexp)
1056 {
1057     dVAR;
1058     dXSARGS;
1059     PERL_UNUSED_VAR(cv);
1060
1061     if (items != 1)
1062        Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
1063
1064     SP -= items;
1065
1066     if (SvRXOK(ST(0))) {
1067         XSRETURN_YES;
1068     } else {
1069         XSRETURN_NO;
1070     }
1071 }
1072
1073 XS(XS_re_regnames_count)
1074 {
1075     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1076     SV * ret;
1077     dVAR;
1078     dXSARGS;
1079     PERL_UNUSED_ARG(cv);
1080
1081     if (items != 0)
1082        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1083
1084     SP -= items;
1085
1086     if (!rx)
1087         XSRETURN_UNDEF;
1088
1089     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1090
1091     SPAGAIN;
1092
1093     if (ret) {
1094         XPUSHs(ret);
1095         PUTBACK;
1096         return;
1097     } else {
1098         XSRETURN_UNDEF;
1099     }
1100 }
1101
1102 XS(XS_re_regname)
1103 {
1104     dVAR;
1105     dXSARGS;
1106     REGEXP * rx;
1107     U32 flags;
1108     SV * ret;
1109     PERL_UNUSED_ARG(cv);
1110
1111     if (items < 1 || items > 2)
1112         Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1113
1114     SP -= items;
1115
1116     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1117
1118     if (!rx)
1119         XSRETURN_UNDEF;
1120
1121     if (items == 2 && SvTRUE(ST(1))) {
1122         flags = RXapif_ALL;
1123     } else {
1124         flags = RXapif_ONE;
1125     }
1126     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1127
1128     if (ret) {
1129         if (SvROK(ret))
1130             XPUSHs(ret);
1131         else
1132             XPUSHs(SvREFCNT_inc(ret));
1133         XSRETURN(1);
1134     }
1135     XSRETURN_UNDEF;
1136 }
1137
1138
1139 XS(XS_re_regnames)
1140 {
1141     dVAR;
1142     dXSARGS;
1143     REGEXP * rx;
1144     U32 flags;
1145     SV *ret;
1146     AV *av;
1147     I32 length;
1148     I32 i;
1149     SV **entry;
1150     PERL_UNUSED_ARG(cv);
1151
1152     if (items > 1)
1153         Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
1154
1155     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1156
1157     if (!rx)
1158         XSRETURN_UNDEF;
1159
1160     if (items == 1 && SvTRUE(ST(0))) {
1161         flags = RXapif_ALL;
1162     } else {
1163         flags = RXapif_ONE;
1164     }
1165
1166     SP -= items;
1167
1168     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1169
1170     SPAGAIN;
1171
1172     SP -= items;
1173
1174     if (!ret)
1175         XSRETURN_UNDEF;
1176
1177     av = (AV*)SvRV(ret);
1178     length = av_len(av);
1179
1180     for (i = 0; i <= length; i++) {
1181         entry = av_fetch(av, i, FALSE);
1182
1183         if (!entry)
1184             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1185
1186         XPUSHs(*entry);
1187     }
1188     PUTBACK;
1189     return;
1190 }
1191
1192 XS(XS_re_regexp_pattern)
1193 {
1194     dVAR;
1195     dXSARGS;
1196     REGEXP *re;
1197     PERL_UNUSED_ARG(cv);
1198
1199     if (items != 1)
1200        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regexp_pattern", "sv");
1201
1202     SP -= items;
1203
1204     /*
1205        Checks if a reference is a regex or not. If the parameter is
1206        not a ref, or is not the result of a qr// then returns false
1207        in scalar context and an empty list in list context.
1208        Otherwise in list context it returns the pattern and the
1209        modifiers, in scalar context it returns the pattern just as it
1210        would if the qr// was stringified normally, regardless as
1211        to the class of the variable and any strigification overloads
1212        on the object.
1213     */
1214
1215     if ((re = SvRX(ST(0)))) /* assign deliberate */
1216     {
1217         /* Housten, we have a regex! */
1218         SV *pattern;
1219         STRLEN left = 0;
1220         char reflags[6];
1221
1222         if ( GIMME_V == G_ARRAY ) {
1223             /*
1224                we are in list context so stringify
1225                the modifiers that apply. We ignore "negative
1226                modifiers" in this scenario.
1227             */
1228
1229             const char *fptr = INT_PAT_MODS;
1230             char ch;
1231             U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1232                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1233
1234             while((ch = *fptr++)) {
1235                 if(match_flags & 1) {
1236                     reflags[left++] = ch;
1237                 }
1238                 match_flags >>= 1;
1239             }
1240
1241             pattern = sv_2mortal(newSVpvn(RX_PRECOMP(re),RX_PRELEN(re)));
1242             if (RX_UTF8(re))
1243                 SvUTF8_on(pattern);
1244
1245             /* return the pattern and the modifiers */
1246             XPUSHs(pattern);
1247             XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
1248             XSRETURN(2);
1249         } else {
1250             /* Scalar, so use the string that Perl would return */
1251             /* return the pattern in (?msix:..) format */
1252 #if PERL_VERSION >= 11
1253             pattern = sv_2mortal(newSVsv((SV*)re));
1254 #else
1255             pattern = sv_2mortal(newSVpvn(RX_WRAPPED(re),RX_WRAPLEN(re)));
1256             if (RX_UTF8(re))
1257                 SvUTF8_on(pattern);
1258 #endif
1259             XPUSHs(pattern);
1260             XSRETURN(1);
1261         }
1262     } else {
1263         /* It ain't a regexp folks */
1264         if ( GIMME_V == G_ARRAY ) {
1265             /* return the empty list */
1266             XSRETURN_UNDEF;
1267         } else {
1268             /* Because of the (?:..) wrapping involved in a
1269                stringified pattern it is impossible to get a
1270                result for a real regexp that would evaluate to
1271                false. Therefore we can return PL_sv_no to signify
1272                that the object is not a regex, this means that one
1273                can say
1274
1275                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1276
1277                and not worry about undefined values.
1278             */
1279             XSRETURN_NO;
1280         }
1281     }
1282     /* NOT-REACHED */
1283 }
1284
1285 XS(XS_Tie_Hash_NamedCapture_FETCH)
1286 {
1287     dVAR;
1288     dXSARGS;
1289     REGEXP * rx;
1290     U32 flags;
1291     SV * ret;
1292     PERL_UNUSED_ARG(cv);
1293
1294     if (items != 2)
1295         Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $flags)");
1296
1297     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1298
1299     if (!rx)
1300         XSRETURN_UNDEF;
1301
1302     SP -= items;
1303
1304     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1305     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1306
1307     SPAGAIN;
1308
1309     if (ret) {
1310         if (SvROK(ret))
1311             XPUSHs(ret);
1312         else
1313             XPUSHs(SvREFCNT_inc(ret));
1314         PUTBACK;
1315         return;
1316     }
1317     XSRETURN_UNDEF;
1318 }
1319
1320 XS(XS_Tie_Hash_NamedCapture_STORE)
1321 {
1322     dVAR;
1323     dXSARGS;
1324     REGEXP * rx;
1325     U32 flags;
1326     PERL_UNUSED_ARG(cv);
1327
1328     if (items != 3)
1329         Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $value, $flags)");
1330
1331     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1332
1333     if (!rx) {
1334         if (!PL_localizing)
1335             Perl_croak(aTHX_ PL_no_modify);
1336         else
1337             XSRETURN_UNDEF;
1338     }
1339
1340     SP -= items;
1341
1342     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1343     CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1344 }
1345
1346 XS(XS_Tie_Hash_NamedCapture_DELETE)
1347 {
1348     dVAR;
1349     dXSARGS;
1350     REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1351     U32 flags;
1352     PERL_UNUSED_ARG(cv);
1353
1354     if (items != 2)
1355         Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::DELETE($key, $flags)");
1356
1357     if (!rx)
1358         Perl_croak(aTHX_ PL_no_modify);
1359
1360     SP -= items;
1361
1362     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1363     CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1364 }
1365
1366 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1367 {
1368     dVAR;
1369     dXSARGS;
1370     REGEXP * rx;
1371     U32 flags;
1372     PERL_UNUSED_ARG(cv);
1373
1374     if (items != 1)
1375         Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::CLEAR($flags)");
1376
1377     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1378
1379     if (!rx)
1380         Perl_croak(aTHX_ PL_no_modify);
1381
1382     SP -= items;
1383
1384     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1385     CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1386 }
1387
1388 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1389 {
1390     dVAR;
1391     dXSARGS;
1392     REGEXP * rx;
1393     U32 flags;
1394     SV * ret;
1395     PERL_UNUSED_ARG(cv);
1396
1397     if (items != 2)
1398         Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::EXISTS($key, $flags)");
1399
1400     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1401
1402     if (!rx)
1403         XSRETURN_UNDEF;
1404
1405     SP -= items;
1406
1407     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1408     ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1409
1410     SPAGAIN;
1411
1412         XPUSHs(ret);
1413         PUTBACK;
1414         return;
1415 }
1416
1417 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1418 {
1419     dVAR;
1420     dXSARGS;
1421     REGEXP * rx;
1422     U32 flags;
1423     SV * ret;
1424     PERL_UNUSED_ARG(cv);
1425
1426     if (items != 1)
1427         Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::FIRSTKEY()");
1428
1429     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1430
1431     if (!rx)
1432         XSRETURN_UNDEF;
1433
1434     SP -= items;
1435
1436     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1437     ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1438
1439     SPAGAIN;
1440
1441     if (ret) {
1442         XPUSHs(SvREFCNT_inc(ret));
1443         PUTBACK;
1444     } else {
1445         XSRETURN_UNDEF;
1446     }
1447
1448 }
1449
1450 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1451 {
1452     dVAR;
1453     dXSARGS;
1454     REGEXP * rx;
1455     U32 flags;
1456     SV * ret;
1457     PERL_UNUSED_ARG(cv);
1458
1459     if (items != 2)
1460         Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::NEXTKEY($lastkey)");
1461
1462     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1463
1464     if (!rx)
1465         XSRETURN_UNDEF;
1466
1467     SP -= items;
1468
1469     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1470     ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1471
1472     SPAGAIN;
1473
1474     if (ret) {
1475         XPUSHs(ret);
1476     } else {
1477         XSRETURN_UNDEF;
1478     }
1479     PUTBACK;
1480 }
1481
1482 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1483 {
1484     dVAR;
1485     dXSARGS;
1486     REGEXP * rx;
1487     U32 flags;
1488     SV * ret;
1489     PERL_UNUSED_ARG(cv);
1490
1491     if (items != 1)
1492         Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::SCALAR()");
1493
1494     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1495
1496     if (!rx)
1497         XSRETURN_UNDEF;
1498
1499     SP -= items;
1500
1501     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1502     ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1503
1504     SPAGAIN;
1505
1506     if (ret) {
1507         XPUSHs(ret);
1508         PUTBACK;
1509         return;
1510     } else {
1511         XSRETURN_UNDEF;
1512     }
1513 }
1514
1515 XS(XS_Tie_Hash_NamedCapture_flags)
1516 {
1517     dVAR;
1518     dXSARGS;
1519     PERL_UNUSED_ARG(cv);
1520
1521     if (items != 0)
1522         Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::flags()");
1523
1524         mXPUSHu(RXapif_ONE);
1525         mXPUSHu(RXapif_ALL);
1526         PUTBACK;
1527         return;
1528 }
1529
1530
1531 /*
1532  * Local variables:
1533  * c-indentation-style: bsd
1534  * c-basic-offset: 4
1535  * indent-tabs-mode: t
1536  * End:
1537  *
1538  * ex: set ts=8 sts=4 sw=4 noet:
1539  */