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