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