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