+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
+
+ if (items < 1 || items > 2)
+ croak_xs_usage(cv, "name[, all ]");
+
+ SP -= items;
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx)
+ XSRETURN_UNDEF;
+
+ if (items == 2 && SvTRUE(ST(1))) {
+ flags = RXapif_ALL;
+ } else {
+ flags = RXapif_ONE;
+ }
+ ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
+
+ if (ret) {
+ mXPUSHs(ret);
+ XSRETURN(1);
+ }
+ XSRETURN_UNDEF;
+}
+
+
+XS(XS_re_regnames)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV *ret;
+ AV *av;
+ I32 length;
+ I32 i;
+ SV **entry;
+
+ if (items > 1)
+ croak_xs_usage(cv, "[all]");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx)
+ XSRETURN_UNDEF;
+
+ if (items == 1 && SvTRUE(ST(0))) {
+ flags = RXapif_ALL;
+ } else {
+ flags = RXapif_ONE;
+ }
+
+ SP -= items;
+
+ ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
+
+ SPAGAIN;
+
+ SP -= items;
+
+ if (!ret)
+ XSRETURN_UNDEF;
+
+ av = MUTABLE_AV(SvRV(ret));
+ length = av_len(av);
+
+ for (i = 0; i <= length; i++) {
+ entry = av_fetch(av, i, FALSE);
+
+ if (!entry)
+ Perl_croak(aTHX_ "NULL array element in re::regnames()");
+
+ mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
+ }
+
+ SvREFCNT_dec(ret);
+
+ PUTBACK;
+ return;
+}
+
+XS(XS_re_regexp_pattern)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP *re;
+
+ if (items != 1)
+ croak_xs_usage(cv, "sv");
+
+ SP -= items;
+
+ /*
+ Checks if a reference is a regex or not. If the parameter is
+ not a ref, or is not the result of a qr// then returns false
+ in scalar context and an empty list in list context.
+ Otherwise in list context it returns the pattern and the
+ modifiers, in scalar context it returns the pattern just as it
+ would if the qr// was stringified normally, regardless as
+ to the class of the variable and any strigification overloads
+ on the object.
+ */
+
+ if ((re = SvRX(ST(0)))) /* assign deliberate */
+ {
+ /* Houston, we have a regex! */
+ SV *pattern;
+ STRLEN left = 0;
+ char reflags[sizeof(INT_PAT_MODS)];
+
+ if ( GIMME_V == G_ARRAY ) {
+ /*
+ we are in list context so stringify
+ the modifiers that apply. We ignore "negative
+ modifiers" in this scenario.
+ */
+
+ const char *fptr = INT_PAT_MODS;
+ char ch;
+ U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
+ >> RXf_PMf_STD_PMMOD_SHIFT);
+
+ while((ch = *fptr++)) {
+ if(match_flags & 1) {
+ reflags[left++] = ch;
+ }
+ match_flags >>= 1;
+ }
+
+ pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
+ (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
+
+ /* return the pattern and the modifiers */
+ XPUSHs(pattern);
+ XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
+ XSRETURN(2);
+ } else {
+ /* Scalar, so use the string that Perl would return */
+ /* return the pattern in (?msix:..) format */
+#if PERL_VERSION >= 11
+ pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
+#else
+ pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
+ (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
+#endif
+ XPUSHs(pattern);
+ XSRETURN(1);
+ }
+ } else {
+ /* It ain't a regexp folks */
+ if ( GIMME_V == G_ARRAY ) {
+ /* return the empty list */
+ XSRETURN_UNDEF;
+ } else {
+ /* Because of the (?:..) wrapping involved in a
+ stringified pattern it is impossible to get a
+ result for a real regexp that would evaluate to
+ false. Therefore we can return PL_sv_no to signify
+ that the object is not a regex, this means that one
+ can say
+
+ if (regex($might_be_a_regex) eq '(?:foo)') { }
+
+ and not worry about undefined values.
+ */
+ XSRETURN_NO;
+ }
+ }
+ /* NOT-REACHED */
+}
+
+XS(XS_Tie_Hash_NamedCapture_FETCH)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
+
+ if (items != 2)
+ croak_xs_usage(cv, "$key, $flags");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx || !SvROK(ST(0)))
+ XSRETURN_UNDEF;
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+ ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
+
+ SPAGAIN;
+
+ if (ret) {
+ mXPUSHs(ret);
+ PUTBACK;
+ return;
+ }
+ XSRETURN_UNDEF;
+}
+
+XS(XS_Tie_Hash_NamedCapture_STORE)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+
+ if (items != 3)
+ croak_xs_usage(cv, "$key, $value, $flags");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx || !SvROK(ST(0))) {
+ if (!PL_localizing)
+ Perl_croak_no_modify(aTHX);
+ else
+ XSRETURN_UNDEF;
+ }
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+ CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
+}
+
+XS(XS_Tie_Hash_NamedCapture_DELETE)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+ U32 flags;
+
+ if (items != 2)
+ croak_xs_usage(cv, "$key, $flags");
+
+ if (!rx || !SvROK(ST(0)))
+ Perl_croak_no_modify(aTHX);
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+ CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
+}
+
+XS(XS_Tie_Hash_NamedCapture_CLEAR)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+
+ if (items != 1)
+ croak_xs_usage(cv, "$flags");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx || !SvROK(ST(0)))
+ Perl_croak_no_modify(aTHX);
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+ CALLREG_NAMED_BUFF_CLEAR(rx, flags);
+}
+
+XS(XS_Tie_Hash_NamedCapture_EXISTS)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
+
+ if (items != 2)
+ croak_xs_usage(cv, "$key, $flags");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx || !SvROK(ST(0)))
+ XSRETURN_UNDEF;
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+ ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
+
+ SPAGAIN;
+
+ XPUSHs(ret);
+ PUTBACK;
+ return;
+}
+
+XS(XS_Tie_Hash_NamedCapture_FIRSTK)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
+
+ if (items != 1)
+ croak_xs_usage(cv, "");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx || !SvROK(ST(0)))
+ XSRETURN_UNDEF;
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+ ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
+
+ SPAGAIN;
+
+ if (ret) {
+ mXPUSHs(ret);
+ PUTBACK;
+ } else {
+ XSRETURN_UNDEF;
+ }
+
+}
+
+XS(XS_Tie_Hash_NamedCapture_NEXTK)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
+
+ if (items != 2)
+ croak_xs_usage(cv, "$lastkey");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx || !SvROK(ST(0)))
+ XSRETURN_UNDEF;
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+ ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
+
+ SPAGAIN;
+
+ if (ret) {
+ mXPUSHs(ret);
+ } else {
+ XSRETURN_UNDEF;
+ }
+ PUTBACK;
+}
+
+XS(XS_Tie_Hash_NamedCapture_SCALAR)
+{
+ dVAR;
+ dXSARGS;
+ REGEXP * rx;
+ U32 flags;
+ SV * ret;
+
+ if (items != 1)
+ croak_xs_usage(cv, "");
+
+ rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (!rx || !SvROK(ST(0)))
+ XSRETURN_UNDEF;
+
+ SP -= items;
+
+ flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+ ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
+
+ SPAGAIN;
+
+ if (ret) {
+ mXPUSHs(ret);
+ PUTBACK;
+ return;
+ } else {
+ XSRETURN_UNDEF;
+ }
+}
+
+XS(XS_Tie_Hash_NamedCapture_flags)
+{
+ dVAR;
+ dXSARGS;
+
+ if (items != 0)
+ croak_xs_usage(cv, "");
+
+ mXPUSHu(RXapif_ONE);
+ mXPUSHu(RXapif_ALL);
+ PUTBACK;
+ return;
+}
+
+struct xsub_details {
+ const char *name;
+ XSUBADDR_t xsub;
+ const char *proto;
+};
+
+struct xsub_details details[] = {
+ {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
+ {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
+ {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
+ {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
+ {"version::()", XS_version_noop, NULL},
+ {"version::new", XS_version_new, NULL},
+ {"version::parse", XS_version_new, NULL},
+ {"version::(\"\"", XS_version_stringify, NULL},
+ {"version::stringify", XS_version_stringify, NULL},
+ {"version::(0+", XS_version_numify, NULL},
+ {"version::numify", XS_version_numify, NULL},
+ {"version::normal", XS_version_normal, NULL},
+ {"version::(cmp", XS_version_vcmp, NULL},
+ {"version::(<=>", XS_version_vcmp, NULL},
+ {"version::vcmp", XS_version_vcmp, NULL},
+ {"version::(bool", XS_version_boolean, NULL},
+ {"version::boolean", XS_version_boolean, NULL},
+ {"version::(nomethod", XS_version_noop, NULL},
+ {"version::noop", XS_version_noop, NULL},
+ {"version::is_alpha", XS_version_is_alpha, NULL},
+ {"version::qv", XS_version_qv, NULL},
+ {"version::declare", XS_version_qv, NULL},
+ {"version::is_qv", XS_version_is_qv, NULL},
+ {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
+ {"utf8::valid", XS_utf8_valid, NULL},
+ {"utf8::encode", XS_utf8_encode, NULL},
+ {"utf8::decode", XS_utf8_decode, NULL},
+ {"utf8::upgrade", XS_utf8_upgrade, NULL},
+ {"utf8::downgrade", XS_utf8_downgrade, NULL},
+ {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
+ {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
+ {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
+ {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
+ {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
+ {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
+ {"Internals::hash_seed", XS_Internals_hash_seed, ""},
+ {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
+ {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
+ {"re::is_regexp", XS_re_is_regexp, "$"},
+ {"re::regname", XS_re_regname, ";$$"},
+ {"re::regnames", XS_re_regnames, ";$"},
+ {"re::regnames_count", XS_re_regnames_count, ""},
+ {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
+ {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
+ {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
+ {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
+ {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
+ {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
+ {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
+ {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
+ {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
+ {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
+};
+
+void
+Perl_boot_core_UNIVERSAL(pTHX)
+{
+ dVAR;
+ static const char file[] = __FILE__;
+ struct xsub_details *xsub = details;
+ const struct xsub_details *end
+ = details + sizeof(details) / sizeof(details[0]);
+
+ do {
+ newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
+ } while (++xsub < end);
+
+ /* register the overloading (type 'A') magic */
+ PL_amagic_generation++;
+
+ /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
+ CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
+ = (char *)file;