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