universal.c

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