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