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