universal.c

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