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         SV * const sv = ST(0);
 798         SvGETMAGIC(sv);
 799             if (SvUTF8(sv))
 800                 XSRETURN_YES;
 801             else
 802                 XSRETURN_NO;
 803      }
 804      XSRETURN_EMPTY;
 805 }
 806
 807 XS(XS_utf8_valid)
 808 {
 809      dVAR;
 810      dXSARGS;
 811      if (items != 1)
 812          croak_xs_usage(cv, "sv");
 813     else {
 814         SV * const sv = ST(0);
 815         STRLEN len;
 816         const char * const s = SvPV_const(sv,len);
 817         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 818             XSRETURN_YES;
 819         else
 820             XSRETURN_NO;
 821     }
 822      XSRETURN_EMPTY;
 823 }
 824
 825 XS(XS_utf8_encode)
 826 {
 827     dVAR;
 828     dXSARGS;
 829     if (items != 1)
 830         croak_xs_usage(cv, "sv");
 831     sv_utf8_encode(ST(0));
 832     XSRETURN_EMPTY;
 833 }
 834
 835 XS(XS_utf8_decode)
 836 {
 837     dVAR;
 838     dXSARGS;
 839     if (items != 1)
 840         croak_xs_usage(cv, "sv");
 841     else {
 842         SV * const sv = ST(0);
 843         const bool RETVAL = sv_utf8_decode(sv);
 844         ST(0) = boolSV(RETVAL);
 845         sv_2mortal(ST(0));
 846     }
 847     XSRETURN(1);
 848 }
 849
 850 XS(XS_utf8_upgrade)
 851 {
 852     dVAR;
 853     dXSARGS;
 854     if (items != 1)
 855         croak_xs_usage(cv, "sv");
 856     else {
 857         SV * const sv = ST(0);
 858         STRLEN  RETVAL;
 859         dXSTARG;
 860
 861         RETVAL = sv_utf8_upgrade(sv);
 862         XSprePUSH; PUSHi((IV)RETVAL);
 863     }
 864     XSRETURN(1);
 865 }
 866
 867 XS(XS_utf8_downgrade)
 868 {
 869     dVAR;
 870     dXSARGS;
 871     if (items < 1 || items > 2)
 872         croak_xs_usage(cv, "sv, failok=0");
 873     else {
 874         SV * const sv = ST(0);
 875         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 876         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 877
 878         ST(0) = boolSV(RETVAL);
 879         sv_2mortal(ST(0));
 880     }
 881     XSRETURN(1);
 882 }
 883
 884 XS(XS_utf8_native_to_unicode)
 885 {
 886  dVAR;
 887  dXSARGS;
 888  const UV uv = SvUV(ST(0));
 889
 890  if (items > 1)
 891      croak_xs_usage(cv, "sv");
 892
 893  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 894  XSRETURN(1);
 895 }
 896
 897 XS(XS_utf8_unicode_to_native)
 898 {
 899  dVAR;
 900  dXSARGS;
 901  const UV uv = SvUV(ST(0));
 902
 903  if (items > 1)
 904      croak_xs_usage(cv, "sv");
 905
 906  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 907  XSRETURN(1);
 908 }
 909
 910 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 911 {
 912     dVAR;
 913     dXSARGS;
 914     SV * const sv = SvRV(ST(0));
 915     PERL_UNUSED_ARG(cv);
 916
 917     if (items == 1) {
 918          if (SvREADONLY(sv))
 919              XSRETURN_YES;
 920          else
 921              XSRETURN_NO;
 922     }
 923     else if (items == 2) {
 924         if (SvTRUE(ST(1))) {
 925             SvREADONLY_on(sv);
 926             XSRETURN_YES;
 927         }
 928         else {
 929             /* I hope you really know what you are doing. */
 930             SvREADONLY_off(sv);
 931             XSRETURN_NO;
 932         }
 933     }
 934     XSRETURN_UNDEF; /* Can't happen. */
 935 }
 936
 937 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 938 {
 939     dVAR;
 940     dXSARGS;
 941     SV * const sv = SvRV(ST(0));
 942     PERL_UNUSED_ARG(cv);
 943
 944     if (items == 1)
 945          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 946     else if (items == 2) {
 947          /* I hope you really know what you are doing. */
 948          SvREFCNT(sv) = SvIV(ST(1));
 949          XSRETURN_IV(SvREFCNT(sv));
 950     }
 951     XSRETURN_UNDEF; /* Can't happen. */
 952 }
 953
 954 XS(XS_Internals_hv_clear_placehold)
 955 {
 956     dVAR;
 957     dXSARGS;
 958
 959     if (items != 1)
 960         croak_xs_usage(cv, "hv");
 961     else {
 962         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 963         hv_clear_placeholders(hv);
 964         XSRETURN(0);
 965     }
 966 }
 967
 968 XS(XS_PerlIO_get_layers)
 969 {
 970     dVAR;
 971     dXSARGS;
 972     if (items < 1 || items % 2 == 0)
 973         croak_xs_usage(cv, "filehandle[,args]");
 974 #ifdef USE_PERLIO
 975     {
 976         SV *    sv;
 977         GV *    gv;
 978         IO *    io;
 979         bool    input = TRUE;
 980         bool    details = FALSE;
 981
 982         if (items > 1) {
 983              SV * const *svp;
 984              for (svp = MARK + 2; svp <= SP; svp += 2) {
 985                   SV * const * const varp = svp;
 986                   SV * const * const valp = svp + 1;
 987                   STRLEN klen;
 988                   const char * const key = SvPV_const(*varp, klen);
 989
 990                   switch (*key) {
 991                   case 'i':
 992                        if (klen == 5 && memEQ(key, "input", 5)) {
 993                             input = SvTRUE(*valp);
 994                             break;
 995                        }
 996                        goto fail;
 997                   case 'o':
 998                        if (klen == 6 && memEQ(key, "output", 6)) {
 999                             input = !SvTRUE(*valp);
1000                             break;
1001                        }
1002                        goto fail;
1003                   case 'd':
1004                        if (klen == 7 && memEQ(key, "details", 7)) {
1005                             details = SvTRUE(*valp);
1006                             break;
1007                        }
1008                        goto fail;
1009                   default:
1010                   fail:
1011                        Perl_croak(aTHX_
1012                                   "get_layers: unknown argument '%s'",
1013                                   key);
1014                   }
1015              }
1016
1017              SP -= (items - 1);
1018         }
1019
1020         sv = POPs;
1021         gv = MUTABLE_GV(sv);
1022
1023         if (!isGV(sv)) {
1024              if (SvROK(sv) && isGV(SvRV(sv)))
1025                   gv = MUTABLE_GV(SvRV(sv));
1026              else if (SvPOKp(sv))
1027                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
1028         }
1029
1030         if (gv && (io = GvIO(gv))) {
1031              AV* const av = PerlIO_get_layers(aTHX_ input ?
1032                                         IoIFP(io) : IoOFP(io));
1033              I32 i;
1034              const I32 last = av_len(av);
1035              I32 nitem = 0;
1036
1037              for (i = last; i >= 0; i -= 3) {
1038                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1039                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1040                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
1041
1042                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1043                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1044                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1045
1046                   if (details) {
1047                       /* Indents of 5? Yuck.  */
1048                       /* We know that PerlIO_get_layers creates a new SV for
1049                          the name and flags, so we can just take a reference
1050                          and "steal" it when we free the AV below.  */
1051                        XPUSHs(namok
1052                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1053                               : &PL_sv_undef);
1054                        XPUSHs(argok
1055                               ? newSVpvn_flags(SvPVX_const(*argsvp),
1056                                                SvCUR(*argsvp),
1057                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1058                                                | SVs_TEMP)
1059                               : &PL_sv_undef);
1060                        XPUSHs(flgok
1061                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1062                               : &PL_sv_undef);
1063                        nitem += 3;
1064                   }
1065                   else {
1066                        if (namok && argok)
1067                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1068                                                  SVfARG(*namsvp),
1069                                                  SVfARG(*argsvp))));
1070                        else if (namok)
1071                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1072                        else
1073                             XPUSHs(&PL_sv_undef);
1074                        nitem++;
1075                        if (flgok) {
1076                             const IV flags = SvIVX(*flgsvp);
1077
1078                             if (flags & PERLIO_F_UTF8) {
1079                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1080                                  nitem++;
1081                             }
1082                        }
1083                   }
1084              }
1085
1086              SvREFCNT_dec(av);
1087
1088              XSRETURN(nitem);
1089         }
1090     }
1091 #endif
1092
1093     XSRETURN(0);
1094 }
1095
1096 XS(XS_Internals_hash_seed)
1097 {
1098     dVAR;
1099     /* Using dXSARGS would also have dITEM and dSP,
1100      * which define 2 unused local variables.  */
1101     dAXMARK;
1102     PERL_UNUSED_ARG(cv);
1103     PERL_UNUSED_VAR(mark);
1104     XSRETURN_UV(PERL_HASH_SEED);
1105 }
1106
1107 XS(XS_Internals_rehash_seed)
1108 {
1109     dVAR;
1110     /* Using dXSARGS would also have dITEM and dSP,
1111      * which define 2 unused local variables.  */
1112     dAXMARK;
1113     PERL_UNUSED_ARG(cv);
1114     PERL_UNUSED_VAR(mark);
1115     XSRETURN_UV(PL_rehash_seed);
1116 }
1117
1118 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1119 {
1120     dVAR;
1121     dXSARGS;
1122     PERL_UNUSED_ARG(cv);
1123     if (SvROK(ST(0))) {
1124         const HV * const hv = (const HV *) SvRV(ST(0));
1125         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1126             if (HvREHASH(hv))
1127                 XSRETURN_YES;
1128             else
1129                 XSRETURN_NO;
1130         }
1131     }
1132     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1133 }
1134
1135 XS(XS_re_is_regexp)
1136 {
1137     dVAR;
1138     dXSARGS;
1139     PERL_UNUSED_VAR(cv);
1140
1141     if (items != 1)
1142         croak_xs_usage(cv, "sv");
1143
1144     SP -= items;
1145
1146     if (SvRXOK(ST(0))) {
1147         XSRETURN_YES;
1148     } else {
1149         XSRETURN_NO;
1150     }
1151 }
1152
1153 XS(XS_re_regnames_count)
1154 {
1155     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1156     SV * ret;
1157     dVAR;
1158     dXSARGS;
1159
1160     if (items != 0)
1161         croak_xs_usage(cv, "");
1162
1163     SP -= items;
1164
1165     if (!rx)
1166         XSRETURN_UNDEF;
1167
1168     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1169
1170     SPAGAIN;
1171
1172     if (ret) {
1173         mXPUSHs(ret);
1174         PUTBACK;
1175         return;
1176     } else {
1177         XSRETURN_UNDEF;
1178     }
1179 }
1180
1181 XS(XS_re_regname)
1182 {
1183     dVAR;
1184     dXSARGS;
1185     REGEXP * rx;
1186     U32 flags;
1187     SV * ret;
1188
1189     if (items < 1 || items > 2)
1190         croak_xs_usage(cv, "name[, all ]");
1191
1192     SP -= items;
1193
1194     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1195
1196     if (!rx)
1197         XSRETURN_UNDEF;
1198
1199     if (items == 2 && SvTRUE(ST(1))) {
1200         flags = RXapif_ALL;
1201     } else {
1202         flags = RXapif_ONE;
1203     }
1204     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1205
1206     if (ret) {
1207         mXPUSHs(ret);
1208         XSRETURN(1);
1209     }
1210     XSRETURN_UNDEF;
1211 }
1212
1213
1214 XS(XS_re_regnames)
1215 {
1216     dVAR;
1217     dXSARGS;
1218     REGEXP * rx;
1219     U32 flags;
1220     SV *ret;
1221     AV *av;
1222     I32 length;
1223     I32 i;
1224     SV **entry;
1225
1226     if (items > 1)
1227         croak_xs_usage(cv, "[all]");
1228
1229     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1230
1231     if (!rx)
1232         XSRETURN_UNDEF;
1233
1234     if (items == 1 && SvTRUE(ST(0))) {
1235         flags = RXapif_ALL;
1236     } else {
1237         flags = RXapif_ONE;
1238     }
1239
1240     SP -= items;
1241
1242     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1243
1244     SPAGAIN;
1245
1246     SP -= items;
1247
1248     if (!ret)
1249         XSRETURN_UNDEF;
1250
1251     av = MUTABLE_AV(SvRV(ret));
1252     length = av_len(av);
1253
1254     for (i = 0; i <= length; i++) {
1255         entry = av_fetch(av, i, FALSE);
1256
1257         if (!entry)
1258             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1259
1260         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1261     }
1262
1263     SvREFCNT_dec(ret);
1264
1265     PUTBACK;
1266     return;
1267 }
1268
1269 XS(XS_re_regexp_pattern)
1270 {
1271     dVAR;
1272     dXSARGS;
1273     REGEXP *re;
1274
1275     if (items != 1)
1276         croak_xs_usage(cv, "sv");
1277
1278     SP -= items;
1279
1280     /*
1281        Checks if a reference is a regex or not. If the parameter is
1282        not a ref, or is not the result of a qr// then returns false
1283        in scalar context and an empty list in list context.
1284        Otherwise in list context it returns the pattern and the
1285        modifiers, in scalar context it returns the pattern just as it
1286        would if the qr// was stringified normally, regardless as
1287        to the class of the variable and any strigification overloads
1288        on the object.
1289     */
1290
1291     if ((re = SvRX(ST(0)))) /* assign deliberate */
1292     {
1293         /* Housten, we have a regex! */
1294         SV *pattern;
1295         STRLEN left = 0;
1296         char reflags[6];
1297
1298         if ( GIMME_V == G_ARRAY ) {
1299             /*
1300                we are in list context so stringify
1301                the modifiers that apply. We ignore "negative
1302                modifiers" in this scenario.
1303             */
1304
1305             const char *fptr = INT_PAT_MODS;
1306             char ch;
1307             U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1308                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1309
1310             while((ch = *fptr++)) {
1311                 if(match_flags & 1) {
1312                     reflags[left++] = ch;
1313                 }
1314                 match_flags >>= 1;
1315             }
1316
1317             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1318                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1319
1320             /* return the pattern and the modifiers */
1321             XPUSHs(pattern);
1322             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1323             XSRETURN(2);
1324         } else {
1325             /* Scalar, so use the string that Perl would return */
1326             /* return the pattern in (?msix:..) format */
1327 #if PERL_VERSION >= 11
1328             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1329 #else
1330             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1331                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1332 #endif
1333             XPUSHs(pattern);
1334             XSRETURN(1);
1335         }
1336     } else {
1337         /* It ain't a regexp folks */
1338         if ( GIMME_V == G_ARRAY ) {
1339             /* return the empty list */
1340             XSRETURN_UNDEF;
1341         } else {
1342             /* Because of the (?:..) wrapping involved in a
1343                stringified pattern it is impossible to get a
1344                result for a real regexp that would evaluate to
1345                false. Therefore we can return PL_sv_no to signify
1346                that the object is not a regex, this means that one
1347                can say
1348
1349                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1350
1351                and not worry about undefined values.
1352             */
1353             XSRETURN_NO;
1354         }
1355     }
1356     /* NOT-REACHED */
1357 }
1358
1359 XS(XS_Tie_Hash_NamedCapture_FETCH)
1360 {
1361     dVAR;
1362     dXSARGS;
1363     REGEXP * rx;
1364     U32 flags;
1365     SV * ret;
1366
1367     if (items != 2)
1368         croak_xs_usage(cv, "$key, $flags");
1369
1370     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1371
1372     if (!rx || !SvROK(ST(0)))
1373         XSRETURN_UNDEF;
1374
1375     SP -= items;
1376
1377     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1378     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1379
1380     SPAGAIN;
1381
1382     if (ret) {
1383         mXPUSHs(ret);
1384         PUTBACK;
1385         return;
1386     }
1387     XSRETURN_UNDEF;
1388 }
1389
1390 XS(XS_Tie_Hash_NamedCapture_STORE)
1391 {
1392     dVAR;
1393     dXSARGS;
1394     REGEXP * rx;
1395     U32 flags;
1396
1397     if (items != 3)
1398         croak_xs_usage(cv, "$key, $value, $flags");
1399
1400     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1401
1402     if (!rx || !SvROK(ST(0))) {
1403         if (!PL_localizing)
1404             Perl_croak(aTHX_ "%s", PL_no_modify);
1405         else
1406             XSRETURN_UNDEF;
1407     }
1408
1409     SP -= items;
1410
1411     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1412     CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
1413 }
1414
1415 XS(XS_Tie_Hash_NamedCapture_DELETE)
1416 {
1417     dVAR;
1418     dXSARGS;
1419     REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1420     U32 flags;
1421
1422     if (items != 2)
1423         croak_xs_usage(cv, "$key, $flags");
1424
1425     if (!rx || !SvROK(ST(0)))
1426         Perl_croak(aTHX_ "%s", PL_no_modify);
1427
1428     SP -= items;
1429
1430     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1431     CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1432 }
1433
1434 XS(XS_Tie_Hash_NamedCapture_CLEAR)
1435 {
1436     dVAR;
1437     dXSARGS;
1438     REGEXP * rx;
1439     U32 flags;
1440
1441     if (items != 1)
1442         croak_xs_usage(cv, "$flags");
1443
1444     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1445
1446     if (!rx || !SvROK(ST(0)))
1447         Perl_croak(aTHX_ "%s", PL_no_modify);
1448
1449     SP -= items;
1450
1451     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1452     CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1453 }
1454
1455 XS(XS_Tie_Hash_NamedCapture_EXISTS)
1456 {
1457     dVAR;
1458     dXSARGS;
1459     REGEXP * rx;
1460     U32 flags;
1461     SV * ret;
1462
1463     if (items != 2)
1464         croak_xs_usage(cv, "$key, $flags");
1465
1466     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1467
1468     if (!rx || !SvROK(ST(0)))
1469         XSRETURN_UNDEF;
1470
1471     SP -= items;
1472
1473     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1474     ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1475
1476     SPAGAIN;
1477
1478         XPUSHs(ret);
1479         PUTBACK;
1480         return;
1481 }
1482
1483 XS(XS_Tie_Hash_NamedCapture_FIRSTK)
1484 {
1485     dVAR;
1486     dXSARGS;
1487     REGEXP * rx;
1488     U32 flags;
1489     SV * ret;
1490
1491     if (items != 1)
1492         croak_xs_usage(cv, "");
1493
1494     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1495
1496     if (!rx || !SvROK(ST(0)))
1497         XSRETURN_UNDEF;
1498
1499     SP -= items;
1500
1501     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1502     ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1503
1504     SPAGAIN;
1505
1506     if (ret) {
1507         mXPUSHs(ret);
1508         PUTBACK;
1509     } else {
1510         XSRETURN_UNDEF;
1511     }
1512
1513 }
1514
1515 XS(XS_Tie_Hash_NamedCapture_NEXTK)
1516 {
1517     dVAR;
1518     dXSARGS;
1519     REGEXP * rx;
1520     U32 flags;
1521     SV * ret;
1522
1523     if (items != 2)
1524         croak_xs_usage(cv, "$lastkey");
1525
1526     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1527
1528     if (!rx || !SvROK(ST(0)))
1529         XSRETURN_UNDEF;
1530
1531     SP -= items;
1532
1533     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1534     ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1535
1536     SPAGAIN;
1537
1538     if (ret) {
1539         mXPUSHs(ret);
1540     } else {
1541         XSRETURN_UNDEF;
1542     }
1543     PUTBACK;
1544 }
1545
1546 XS(XS_Tie_Hash_NamedCapture_SCALAR)
1547 {
1548     dVAR;
1549     dXSARGS;
1550     REGEXP * rx;
1551     U32 flags;
1552     SV * ret;
1553
1554     if (items != 1)
1555         croak_xs_usage(cv, "");
1556
1557     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1558
1559     if (!rx || !SvROK(ST(0)))
1560         XSRETURN_UNDEF;
1561
1562     SP -= items;
1563
1564     flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
1565     ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1566
1567     SPAGAIN;
1568
1569     if (ret) {
1570         mXPUSHs(ret);
1571         PUTBACK;
1572         return;
1573     } else {
1574         XSRETURN_UNDEF;
1575     }
1576 }
1577
1578 XS(XS_Tie_Hash_NamedCapture_flags)
1579 {
1580     dVAR;
1581     dXSARGS;
1582
1583     if (items != 0)
1584         croak_xs_usage(cv, "");
1585
1586         mXPUSHu(RXapif_ONE);
1587         mXPUSHu(RXapif_ALL);
1588         PUTBACK;
1589         return;
1590 }
1591
1592
1593 /*
1594  * Local variables:
1595  * c-indentation-style: bsd
1596  * c-basic-offset: 4
1597  * indent-tabs-mode: t
1598  * End:
1599  *
1600  * ex: set ts=8 sts=4 sw=4 noet:
1601  */