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