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