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