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