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         XPUSHs(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         if (SvROK(ret))
1154             XPUSHs(ret);
1155         else
1156             XPUSHs(SvREFCNT_inc(ret));
1157         XSRETURN(1);
1158     }
1159     XSRETURN_UNDEF;
1160 }
1161
1162
1163 XS(XS_re_regnames)
1164 {
1165     dVAR;
1166     dXSARGS;
1167     REGEXP * rx;
1168     U32 flags;
1169     SV *ret;
1170     AV *av;
1171     I32 length;
1172     I32 i;
1173     SV **entry;
1174
1175     if (items > 1)
1176         croak_xs_usage(cv, "[all]");
1177
1178     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1179
1180     if (!rx)
1181         XSRETURN_UNDEF;
1182
1183     if (items == 1 && SvTRUE(ST(0))) {
1184         flags = RXapif_ALL;
1185     } else {
1186         flags = RXapif_ONE;
1187     }
1188
1189     SP -= items;
1190
1191     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1192
1193     SPAGAIN;
1194
1195     SP -= items;
1196
1197     if (!ret)
1198         XSRETURN_UNDEF;
1199
1200     av = (AV*)SvRV(ret);
1201     length = av_len(av);
1202
1203     for (i = 0; i <= length; i++) {
1204         entry = av_fetch(av, i, FALSE);
1205
1206         if (!entry)
1207             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1208
1209         XPUSHs(*entry);
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         if (SvROK(ret))
1330             XPUSHs(ret);
1331         else
1332             XPUSHs(SvREFCNT_inc(ret));
1333         PUTBACK;
1334         return;
1335     }
1336     XSRETURN_UNDEF;
1337 }
1338
1339 XS(XS_Tie_Hash_NamedCapture_STORE)
1340 {
1341     dVAR;
1342     dXSARGS;
1343     REGEXP * rx;
1344     U32 flags;
1345
1346     if (items != 3)
1347         croak_xs_usage(cv, "$key, $value, $flags");
1348
1349     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1350
1351     if (!rx) {
1352         if (!PL_localizing)
1353             Perl_croak(aTHX_ PL_no_modify);
1354         else
1355             XSRETURN_UNDEF;
1356     }
1357
1358     SP -= items;
1359
1360     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1361     CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1362 }
1363
1364 XS(XS_Tie_Hash_NamedCapture_DELETE)
1365 {
1366     dVAR;
1367     dXSARGS;
1368     REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1369     U32 flags;
1370
1371     if (items != 2)
1372         croak_xs_usage(cv, "$key, $flags");
1373
1374     if (!rx)
1375         Perl_croak(aTHX_ PL_no_modify);
1376
1377     SP -= items;
1378
1379     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1380     CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1381 }
1382
1383 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1384 {
1385     dVAR;
1386     dXSARGS;
1387     REGEXP * rx;
1388     U32 flags;
1389
1390     if (items != 1)
1391         croak_xs_usage(cv, "$flags");
1392
1393     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1394
1395     if (!rx)
1396         Perl_croak(aTHX_ PL_no_modify);
1397
1398     SP -= items;
1399
1400     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1401     CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1402 }
1403
1404 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1405 {
1406     dVAR;
1407     dXSARGS;
1408     REGEXP * rx;
1409     U32 flags;
1410     SV * ret;
1411
1412     if (items != 2)
1413         croak_xs_usage(cv, "$key, $flags");
1414
1415     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1416
1417     if (!rx)
1418         XSRETURN_UNDEF;
1419
1420     SP -= items;
1421
1422     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1423     ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1424
1425     SPAGAIN;
1426
1427         XPUSHs(ret);
1428         PUTBACK;
1429         return;
1430 }
1431
1432 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1433 {
1434     dVAR;
1435     dXSARGS;
1436     REGEXP * rx;
1437     U32 flags;
1438     SV * ret;
1439
1440     if (items != 1)
1441         croak_xs_usage(cv, "");
1442
1443     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1444
1445     if (!rx)
1446         XSRETURN_UNDEF;
1447
1448     SP -= items;
1449
1450     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1451     ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1452
1453     SPAGAIN;
1454
1455     if (ret) {
1456         XPUSHs(SvREFCNT_inc(ret));
1457         PUTBACK;
1458     } else {
1459         XSRETURN_UNDEF;
1460     }
1461
1462 }
1463
1464 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1465 {
1466     dVAR;
1467     dXSARGS;
1468     REGEXP * rx;
1469     U32 flags;
1470     SV * ret;
1471
1472     if (items != 2)
1473         croak_xs_usage(cv, "$lastkey");
1474
1475     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1476
1477     if (!rx)
1478         XSRETURN_UNDEF;
1479
1480     SP -= items;
1481
1482     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1483     ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1484
1485     SPAGAIN;
1486
1487     if (ret) {
1488         XPUSHs(ret);
1489     } else {
1490         XSRETURN_UNDEF;
1491     }
1492     PUTBACK;
1493 }
1494
1495 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1496 {
1497     dVAR;
1498     dXSARGS;
1499     REGEXP * rx;
1500     U32 flags;
1501     SV * ret;
1502
1503     if (items != 1)
1504         croak_xs_usage(cv, "");
1505
1506     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1507
1508     if (!rx)
1509         XSRETURN_UNDEF;
1510
1511     SP -= items;
1512
1513     flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1514     ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1515
1516     SPAGAIN;
1517
1518     if (ret) {
1519         XPUSHs(ret);
1520         PUTBACK;
1521         return;
1522     } else {
1523         XSRETURN_UNDEF;
1524     }
1525 }
1526
1527 XS(XS_Tie_Hash_NamedCapture_flags)
1528 {
1529     dVAR;
1530     dXSARGS;
1531
1532     if (items != 0)
1533         croak_xs_usage(cv, "");
1534
1535         mXPUSHu(RXapif_ONE);
1536         mXPUSHu(RXapif_ALL);
1537         PUTBACK;
1538         return;
1539 }
1540
1541
1542 /*
1543  * Local variables:
1544  * c-indentation-style: bsd
1545  * c-basic-offset: 4
1546  * indent-tabs-mode: t
1547  * End:
1548  *
1549  * ex: set ts=8 sts=4 sw=4 noet:
1550  */