*
* It is also used to store XS functions that need to be present in
* miniperl for a lack of a better place to put them. It might be
- * clever to move them to seperate XS files which would then be pulled
+ * clever to move them to separate XS files which would then be pulled
* in by some to-be-written build process.
*/
#include "perliol.h" /* For the PERLIO_F_XXX */
#endif
-static HV *
-S_get_isa_hash(pTHX_ HV *const stash)
-{
- dVAR;
- struct mro_meta *const meta = HvMROMETA(stash);
-
- PERL_ARGS_ASSERT_GET_ISA_HASH;
-
- if (!meta->isa) {
- AV *const isa = mro_get_linear_isa(stash);
- if (!meta->isa) {
- HV *const isa_hash = newHV();
- /* Linearisation didn't build it for us, so do it here. */
- SV *const *svp = AvARRAY(isa);
- SV *const *const svp_end = svp + AvFILLp(isa) + 1;
- const HEK *const canon_name = HvNAME_HEK(stash);
-
- while (svp < svp_end) {
- (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
- }
-
- (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
- HEK_LEN(canon_name), HEK_FLAGS(canon_name),
- HV_FETCH_ISSTORE, &PL_sv_undef,
- HEK_HASH(canon_name));
- (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
-
- SvREADONLY_on(isa_hash);
-
- meta->isa = isa_hash;
- }
- }
- return meta->isa;
-}
-
/*
* Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
* The main guts of traverse_isa was actually copied from gv_fetchmeth
{
dVAR;
const struct mro_meta *const meta = HvMROMETA(stash);
- HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash);
+ HV *isa = meta->isa;
STRLEN len = strlen(name);
const HV *our_stash;
PERL_ARGS_ASSERT_ISA_LOOKUP;
+ if (!isa) {
+ (void)mro_get_linear_isa(stash);
+ isa = meta->isa;
+ }
+
if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only
a char * argument*/,
HV_FETCH_ISEXISTS, NULL, 0)) {
}
/* A stash/class can go by many names (ie. User == main::User), so
- we use the name in the stash itself, which is canonical. */
+ we use the HvENAME in the stash itself, which is canonical, falling
+ back to HvNAME if necessary. */
our_stash = gv_stashpvn(name, len, 0);
if (our_stash) {
- HEK *const canon_name = HvNAME_HEK(our_stash);
+ HEK *canon_name = HvENAME_HEK(our_stash);
+ if (!canon_name) canon_name = HvNAME_HEK(our_stash);
if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
HEK_FLAGS(canon_name),
PERL_UNUSED_ARG(cv);
if (items != 2)
- Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
+ Perl_croak(aTHX_ "Usage: invocand->DOES(kind)");
else {
SV * const sv = ST(0);
const char *name;
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
+ to the class of the variable and any stringification overloads
on the object.
*/
if ( GIMME_V == G_ARRAY ) {
STRLEN left = 0;
- char reflags[sizeof(INT_PAT_MODS) + 1]; /* The +1 is for the charset
- modifier */
+ char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
const char *fptr;
char ch;
U16 match_flags;
/*
we are in list context so stringify
the modifiers that apply. We ignore "negative
- modifiers" in this scenario.
+ modifiers" in this scenario, and the default character set
*/
- if (RX_EXTFLAGS(re) & RXf_PMf_LOCALE) {
- reflags[left++] = LOCALE_PAT_MOD;
- }
- else if (RX_EXTFLAGS(re) & RXf_PMf_UNICODE) {
- reflags[left++] = UNICODE_PAT_MOD;
+ if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
+ STRLEN len;
+ const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
+ &len);
+ Copy(name, reflags + left, len, char);
+ left += len;
}
fptr = INT_PAT_MODS;
- match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
+ match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
>> RXf_PMf_STD_PMMOD_SHIFT);
while((ch = *fptr++)) {
/* NOT-REACHED */
}
-static void
-S_named_capture_common(pTHX_ CV *const cv, const bool fatal, const int expect,
- const bool discard, const U32 action)
-{
- dVAR;
- dXSARGS;
- REGEXP * rx;
- U32 flags;
- SV * ret;
-
- if (items != expect)
- croak_xs_usage(cv, expect == 2 ? "$key"
- : (expect == 3 ? "$key, $value" : ""));
-
- rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
-
- if (!rx || !SvROK(ST(0))) {
- if (fatal)
- Perl_croak_no_modify(aTHX);
- else
- XSRETURN_UNDEF;
- }
-
- SP -= items;
- PUTBACK;
-
- flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
- ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
- expect >= 3 ? ST(2) : NULL, flags | action);
-
- if (discard) {
- /* Called with G_DISCARD, so our return stack state is thrown away.
- Hence if we were returned anything, free it immediately. */
- SvREFCNT_dec(ret);
- XSRETURN_EMPTY;
- }
-
- SPAGAIN;
- PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
- XSRETURN(1);
-}
-
-XS(XS_Tie_Hash_NamedCapture_FETCH)
-{
- S_named_capture_common(aTHX_ cv, FALSE, 2, FALSE, RXapif_FETCH);
-}
-
-XS(XS_Tie_Hash_NamedCapture_STORE)
-{
- S_named_capture_common(aTHX_ cv, TRUE, 3, TRUE, RXapif_STORE);
-}
-
-XS(XS_Tie_Hash_NamedCapture_DELETE)
-{
- S_named_capture_common(aTHX_ cv, TRUE, 2, FALSE, RXapif_DELETE);
-}
-
-XS(XS_Tie_Hash_NamedCapture_CLEAR)
-{
- S_named_capture_common(aTHX_ cv, TRUE, 1, TRUE, RXapif_CLEAR);
-}
-
-XS(XS_Tie_Hash_NamedCapture_EXISTS)
-{
- S_named_capture_common(aTHX_ cv, FALSE, 2, FALSE, RXapif_EXISTS);
-}
-
-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;
- PUTBACK;
-
- flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
- ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), NULL, flags | RXapif_FIRSTKEY);
-
- SPAGAIN;
- PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
- XSRETURN(1);
-}
-
-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;
- PUTBACK;
-
- flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
- ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), ST(1), flags | RXapif_NEXTKEY);
-
- SPAGAIN;
- PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
- XSRETURN(1);
-}
-
-XS(XS_Tie_Hash_NamedCapture_SCALAR)
-{
- S_named_capture_common(aTHX_ cv, FALSE, 1, FALSE, RXapif_SCALAR);
-}
-
-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;
{"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