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