universal.c

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