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