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_Regexp_DESTROY);
 237 XS(XS_Internals_hash_seed);
 238 XS(XS_Internals_rehash_seed);
 239 XS(XS_Internals_HvREHASH);
 240 XS(XS_Internals_inc_sub_generation);
 241 XS(XS_re_is_regexp);
 242 XS(XS_re_regname);
 243 XS(XS_re_regnames);
 244 XS(XS_re_regnames_count);
 245 XS(XS_re_regexp_pattern);
 246 XS(XS_Tie_Hash_NamedCapture_FETCH);
 247 XS(XS_Tie_Hash_NamedCapture_STORE);
 248 XS(XS_Tie_Hash_NamedCapture_DELETE);
 249 XS(XS_Tie_Hash_NamedCapture_CLEAR);
 250 XS(XS_Tie_Hash_NamedCapture_EXISTS);
 251 XS(XS_Tie_Hash_NamedCapture_FIRSTK);
 252 XS(XS_Tie_Hash_NamedCapture_NEXTK);
 253 XS(XS_Tie_Hash_NamedCapture_SCALAR);
 254 XS(XS_Tie_Hash_NamedCapture_flags);
 255
 256 void
 257 Perl_boot_core_UNIVERSAL(pTHX)
 258 {
 259     dVAR;
 260     static const char file[] = __FILE__;
 261
 262     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
 263     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
 264     newXS("UNIVERSAL::DOES",            XS_UNIVERSAL_DOES,        file);
 265     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
 266     {
 267         /* register the overloading (type 'A') magic */
 268         PL_amagic_generation++;
 269         /* Make it findable via fetchmethod */
 270         newXS("version::()", XS_version_noop, file);
 271         newXS("version::new", 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     }
 287     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
 288     newXS("utf8::valid", XS_utf8_valid, file);
 289     newXS("utf8::encode", XS_utf8_encode, file);
 290     newXS("utf8::decode", XS_utf8_decode, file);
 291     newXS("utf8::upgrade", XS_utf8_upgrade, file);
 292     newXS("utf8::downgrade", XS_utf8_downgrade, file);
 293     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
 294     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
 295     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
 296     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 297     newXSproto("Internals::hv_clear_placeholders",
 298                XS_Internals_hv_clear_placehold, file, "\\%");
 299     newXSproto("PerlIO::get_layers",
 300                XS_PerlIO_get_layers, file, "*;@");
 301     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, 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_Regexp_DESTROY)
 931 {
 932     PERL_UNUSED_CONTEXT;
 933     PERL_UNUSED_ARG(cv);
 934 }
 935
 936 XS(XS_PerlIO_get_layers)
 937 {
 938     dVAR;
 939     dXSARGS;
 940     if (items < 1 || items % 2 == 0)
 941         croak_xs_usage(cv, "filehandle[,args]");
 942 #ifdef USE_PERLIO
 943     {
 944         SV *    sv;
 945         GV *    gv;
 946         IO *    io;
 947         bool    input = TRUE;
 948         bool    details = FALSE;
 949
 950         if (items > 1) {
 951              SV * const *svp;
 952              for (svp = MARK + 2; svp <= SP; svp += 2) {
 953                   SV * const * const varp = svp;
 954                   SV * const * const valp = svp + 1;
 955                   STRLEN klen;
 956                   const char * const key = SvPV_const(*varp, klen);
 957
 958                   switch (*key) {
 959                   case 'i':
 960                        if (klen == 5 && memEQ(key, "input", 5)) {
 961                             input = SvTRUE(*valp);
 962                             break;
 963                        }
 964                        goto fail;
 965                   case 'o':
 966                        if (klen == 6 && memEQ(key, "output", 6)) {
 967                             input = !SvTRUE(*valp);
 968                             break;
 969                        }
 970                        goto fail;
 971                   case 'd':
 972                        if (klen == 7 && memEQ(key, "details", 7)) {
 973                             details = SvTRUE(*valp);
 974                             break;
 975                        }
 976                        goto fail;
 977                   default:
 978                   fail:
 979                        Perl_croak(aTHX_
 980                                   "get_layers: unknown argument '%s'",
 981                                   key);
 982                   }
 983              }
 984
 985              SP -= (items - 1);
 986         }
 987
 988         sv = POPs;
 989         gv = MUTABLE_GV(sv);
 990
 991         if (!isGV(sv)) {
 992              if (SvROK(sv) && isGV(SvRV(sv)))
 993                   gv = MUTABLE_GV(SvRV(sv));
 994              else if (SvPOKp(sv))
 995                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
 996         }
 997
 998         if (gv && (io = GvIO(gv))) {
 999              AV* const av = PerlIO_get_layers(aTHX_ input ?
1000                                         IoIFP(io) : IoOFP(io));
1001              I32 i;
1002              const I32 last = av_len(av);
1003              I32 nitem = 0;
1004
1005              for (i = last; i >= 0; i -= 3) {
1006                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1007                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1008                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
1009
1010                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1011                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1012                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1013
1014                   if (details) {
1015                       /* Indents of 5? Yuck.  */
1016                       /* We know that PerlIO_get_layers creates a new SV for
1017                          the name and flags, so we can just take a reference
1018                          and "steal" it when we free the AV below.  */
1019                        XPUSHs(namok
1020                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1021                               : &PL_sv_undef);
1022                        XPUSHs(argok
1023                               ? newSVpvn_flags(SvPVX_const(*argsvp),
1024                                                SvCUR(*argsvp),
1025                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1026                                                | SVs_TEMP)
1027                               : &PL_sv_undef);
1028                        XPUSHs(namok
1029                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1030                               : &PL_sv_undef);
1031                        nitem += 3;
1032                   }
1033                   else {
1034                        if (namok && argok)
1035                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1036                                                  SVfARG(*namsvp),
1037                                                  SVfARG(*argsvp))));
1038                        else if (namok)
1039                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1040                        else
1041                             XPUSHs(&PL_sv_undef);
1042                        nitem++;
1043                        if (flgok) {
1044                             const IV flags = SvIVX(*flgsvp);
1045
1046                             if (flags & PERLIO_F_UTF8) {
1047                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1048                                  nitem++;
1049                             }
1050                        }
1051                   }
1052              }
1053
1054              SvREFCNT_dec(av);
1055
1056              XSRETURN(nitem);
1057         }
1058     }
1059 #endif
1060
1061     XSRETURN(0);
1062 }
1063
1064 XS(XS_Internals_hash_seed)
1065 {
1066     dVAR;
1067     /* Using dXSARGS would also have dITEM and dSP,
1068      * which define 2 unused local variables.  */
1069     dAXMARK;
1070     PERL_UNUSED_ARG(cv);
1071     PERL_UNUSED_VAR(mark);
1072     XSRETURN_UV(PERL_HASH_SEED);
1073 }
1074
1075 XS(XS_Internals_rehash_seed)
1076 {
1077     dVAR;
1078     /* Using dXSARGS would also have dITEM and dSP,
1079      * which define 2 unused local variables.  */
1080     dAXMARK;
1081     PERL_UNUSED_ARG(cv);
1082     PERL_UNUSED_VAR(mark);
1083     XSRETURN_UV(PL_rehash_seed);
1084 }
1085
1086 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1087 {
1088     dVAR;
1089     dXSARGS;
1090     PERL_UNUSED_ARG(cv);
1091     if (SvROK(ST(0))) {
1092         const HV * const hv = (const HV *) SvRV(ST(0));
1093         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1094             if (HvREHASH(hv))
1095                 XSRETURN_YES;
1096             else
1097                 XSRETURN_NO;
1098         }
1099     }
1100     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1101 }
1102
1103 XS(XS_re_is_regexp)
1104 {
1105     dVAR;
1106     dXSARGS;
1107     PERL_UNUSED_VAR(cv);
1108
1109     if (items != 1)
1110         croak_xs_usage(cv, "sv");
1111
1112     SP -= items;
1113
1114     if (SvRXOK(ST(0))) {
1115         XSRETURN_YES;
1116     } else {
1117         XSRETURN_NO;
1118     }
1119 }
1120
1121 XS(XS_re_regnames_count)
1122 {
1123     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1124     SV * ret;
1125     dVAR;
1126     dXSARGS;
1127
1128     if (items != 0)
1129         croak_xs_usage(cv, "");
1130
1131     SP -= items;
1132
1133     if (!rx)
1134         XSRETURN_UNDEF;
1135
1136     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1137
1138     SPAGAIN;
1139
1140     if (ret) {
1141         mXPUSHs(ret);
1142         PUTBACK;
1143         return;
1144     } else {
1145         XSRETURN_UNDEF;
1146     }
1147 }
1148
1149 XS(XS_re_regname)
1150 {
1151     dVAR;
1152     dXSARGS;
1153     REGEXP * rx;
1154     U32 flags;
1155     SV * ret;
1156
1157     if (items < 1 || items > 2)
1158         croak_xs_usage(cv, "name[, all ]");
1159
1160     SP -= items;
1161
1162     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1163
1164     if (!rx)
1165         XSRETURN_UNDEF;
1166
1167     if (items == 2 && SvTRUE(ST(1))) {
1168         flags = RXapif_ALL;
1169     } else {
1170         flags = RXapif_ONE;
1171     }
1172     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1173
1174     if (ret) {
1175         mXPUSHs(ret);
1176         XSRETURN(1);
1177     }
1178     XSRETURN_UNDEF;
1179 }
1180
1181
1182 XS(XS_re_regnames)
1183 {
1184     dVAR;
1185     dXSARGS;
1186     REGEXP * rx;
1187     U32 flags;
1188     SV *ret;
1189     AV *av;
1190     I32 length;
1191     I32 i;
1192     SV **entry;
1193
1194     if (items > 1)
1195         croak_xs_usage(cv, "[all]");
1196
1197     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1198
1199     if (!rx)
1200         XSRETURN_UNDEF;
1201
1202     if (items == 1 && SvTRUE(ST(0))) {
1203         flags = RXapif_ALL;
1204     } else {
1205         flags = RXapif_ONE;
1206     }
1207
1208     SP -= items;
1209
1210     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1211
1212     SPAGAIN;
1213
1214     SP -= items;
1215
1216     if (!ret)
1217         XSRETURN_UNDEF;
1218
1219     av = MUTABLE_AV(SvRV(ret));
1220     length = av_len(av);
1221
1222     for (i = 0; i <= length; i++) {
1223         entry = av_fetch(av, i, FALSE);
1224
1225         if (!entry)
1226             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1227
1228         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1229     }
1230
1231     SvREFCNT_dec(ret);
1232
1233     PUTBACK;
1234     return;
1235 }
1236
1237 XS(XS_re_regexp_pattern)
1238 {
1239     dVAR;
1240     dXSARGS;
1241     REGEXP *re;
1242
1243     if (items != 1)
1244         croak_xs_usage(cv, "sv");
1245
1246     SP -= items;
1247
1248     /*
1249        Checks if a reference is a regex or not. If the parameter is
1250        not a ref, or is not the result of a qr// then returns false
1251        in scalar context and an empty list in list context.
1252        Otherwise in list context it returns the pattern and the
1253        modifiers, in scalar context it returns the pattern just as it
1254        would if the qr// was stringified normally, regardless as
1255        to the class of the variable and any strigification overloads
1256        on the object.
1257     */
1258
1259     if ((re = SvRX(ST(0)))) /* assign deliberate */
1260     {
1261         /* Housten, we have a regex! */
1262         SV *pattern;
1263         STRLEN left = 0;
1264         char reflags[6];
1265
1266         if ( GIMME_V == G_ARRAY ) {
1267             /*
1268                we are in list context so stringify
1269                the modifiers that apply. We ignore "negative
1270                modifiers" in this scenario.
1271             */
1272
1273             const char *fptr = INT_PAT_MODS;
1274             char ch;
1275             U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1276                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1277
1278             while((ch = *fptr++)) {
1279                 if(match_flags & 1) {
1280                     reflags[left++] = ch;
1281                 }
1282                 match_flags >>= 1;
1283             }
1284
1285             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1286                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1287
1288             /* return the pattern and the modifiers */
1289             XPUSHs(pattern);
1290             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1291             XSRETURN(2);
1292         } else {
1293             /* Scalar, so use the string that Perl would return */
1294             /* return the pattern in (?msix:..) format */
1295 #if PERL_VERSION >= 11
1296             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1297 #else
1298             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1299                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1300 #endif
1301             XPUSHs(pattern);
1302             XSRETURN(1);
1303         }
1304     } else {
1305         /* It ain't a regexp folks */
1306         if ( GIMME_V == G_ARRAY ) {
1307             /* return the empty list */
1308             XSRETURN_UNDEF;
1309         } else {
1310             /* Because of the (?:..) wrapping involved in a
1311                stringified pattern it is impossible to get a
1312                result for a real regexp that would evaluate to
1313                false. Therefore we can return PL_sv_no to signify
1314                that the object is not a regex, this means that one
1315                can say
1316
1317                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1318
1319                and not worry about undefined values.
1320             */
1321             XSRETURN_NO;
1322         }
1323     }
1324     /* NOT-REACHED */
1325 }
1326
1327 XS(XS_Tie_Hash_NamedCapture_FETCH)
1328 {
1329     dVAR;
1330     dXSARGS;
1331     REGEXP * rx;
1332     U32 flags;
1333     SV * ret;
1334
1335     if (items != 2)
1336         croak_xs_usage(cv, "$key, $flags");
1337
1338     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1339
1340     if (!rx)
1341         XSRETURN_UNDEF;
1342
1343     SP -= items;
1344
1345     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1346     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1347
1348     SPAGAIN;
1349
1350     if (ret) {
1351         mXPUSHs(ret);
1352         PUTBACK;
1353         return;
1354     }
1355     XSRETURN_UNDEF;
1356 }
1357
1358 XS(XS_Tie_Hash_NamedCapture_STORE)
1359 {
1360     dVAR;
1361     dXSARGS;
1362     REGEXP * rx;
1363     U32 flags;
1364
1365     if (items != 3)
1366         croak_xs_usage(cv, "$key, $value, $flags");
1367
1368     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1369
1370     if (!rx) {
1371         if (!PL_localizing)
1372             Perl_croak(aTHX_ "%s", PL_no_modify);
1373         else
1374             XSRETURN_UNDEF;
1375     }
1376
1377     SP -= items;
1378
1379     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1380     CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1381 }
1382
1383 XS(XS_Tie_Hash_NamedCapture_DELETE)
1384 {
1385     dVAR;
1386     dXSARGS;
1387     REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1388     U32 flags;
1389
1390     if (items != 2)
1391         croak_xs_usage(cv, "$key, $flags");
1392
1393     if (!rx)
1394         Perl_croak(aTHX_ "%s", PL_no_modify);
1395
1396     SP -= items;
1397
1398     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1399     CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1400 }
1401
1402 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1403 {
1404     dVAR;
1405     dXSARGS;
1406     REGEXP * rx;
1407     U32 flags;
1408
1409     if (items != 1)
1410         croak_xs_usage(cv, "$flags");
1411
1412     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1413
1414     if (!rx)
1415         Perl_croak(aTHX_ "%s", PL_no_modify);
1416
1417     SP -= items;
1418
1419     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1420     CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1421 }
1422
1423 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1424 {
1425     dVAR;
1426     dXSARGS;
1427     REGEXP * rx;
1428     U32 flags;
1429     SV * ret;
1430
1431     if (items != 2)
1432         croak_xs_usage(cv, "$key, $flags");
1433
1434     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1435
1436     if (!rx)
1437         XSRETURN_UNDEF;
1438
1439     SP -= items;
1440
1441     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1442     ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1443
1444     SPAGAIN;
1445
1446         XPUSHs(ret);
1447         PUTBACK;
1448         return;
1449 }
1450
1451 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1452 {
1453     dVAR;
1454     dXSARGS;
1455     REGEXP * rx;
1456     U32 flags;
1457     SV * ret;
1458
1459     if (items != 1)
1460         croak_xs_usage(cv, "");
1461
1462     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1463
1464     if (!rx)
1465         XSRETURN_UNDEF;
1466
1467     SP -= items;
1468
1469     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1470     ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1471
1472     SPAGAIN;
1473
1474     if (ret) {
1475         mXPUSHs(ret);
1476         PUTBACK;
1477     } else {
1478         XSRETURN_UNDEF;
1479     }
1480
1481 }
1482
1483 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1484 {
1485     dVAR;
1486     dXSARGS;
1487     REGEXP * rx;
1488     U32 flags;
1489     SV * ret;
1490
1491     if (items != 2)
1492         croak_xs_usage(cv, "$lastkey");
1493
1494     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1495
1496     if (!rx)
1497         XSRETURN_UNDEF;
1498
1499     SP -= items;
1500
1501     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1502     ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1503
1504     SPAGAIN;
1505
1506     if (ret) {
1507         mXPUSHs(ret);
1508     } else {
1509         XSRETURN_UNDEF;
1510     }
1511     PUTBACK;
1512 }
1513
1514 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1515 {
1516     dVAR;
1517     dXSARGS;
1518     REGEXP * rx;
1519     U32 flags;
1520     SV * ret;
1521
1522     if (items != 1)
1523         croak_xs_usage(cv, "");
1524
1525     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1526
1527     if (!rx)
1528         XSRETURN_UNDEF;
1529
1530     SP -= items;
1531
1532     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1533     ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1534
1535     SPAGAIN;
1536
1537     if (ret) {
1538         mXPUSHs(ret);
1539         PUTBACK;
1540         return;
1541     } else {
1542         XSRETURN_UNDEF;
1543     }
1544 }
1545
1546 XS(XS_Tie_Hash_NamedCapture_flags)
1547 {
1548     dVAR;
1549     dXSARGS;
1550
1551     if (items != 0)
1552         croak_xs_usage(cv, "");
1553
1554         mXPUSHu(RXapif_ONE);
1555         mXPUSHu(RXapif_ALL);
1556         PUTBACK;
1557         return;
1558 }
1559
1560
1561 /*
1562  * Local variables:
1563  * c-indentation-style: bsd
1564  * c-basic-offset: 4
1565  * indent-tabs-mode: t
1566  * End:
1567  *
1568  * ex: set ts=8 sts=4 sw=4 noet:
1569  */